simple Common Lisp gv feature

README.md

setf 的一个实现

• yy-ref-table 获取哈希表中的值

• yy-set-table 设置哈希表键值对

• yy-clr-hash 清空哈希表

• yy-dse define-setf-expander

• yy-gse get-setf-expander

• yy-setf setf

• yy-ds defsetf

• yy-dmm define-modify-macro

gv.lisp

(defvar *yy-expander-table* (make-hash-table))
(defun yy-ref-table (s)
  (multiple-value-bind (v f) (gethash s *yy-expander-table*)
    (and f v)))
(defun yy-set-table (s v)
  (setf (gethash s *yy-expander-table*) v))
(defun yy-clr-table ()
  (clrhash *yy-expander-table*))

(defmacro yy-dse (name lambda-ls &rest form)
  (assert (and (not (null lambda-ls))
	       (not (null form))))
  (yy-set-table name (coerce `(lambda ,lambda-ls ,@form) 'function)))

(defun yy-gse (form)
  (if (symbolp form)
      (let ((v (gensym))
	    (g (gensym)))
	(values `(,v) `(,form) `(,g) `(setq ,form ,g) v))
      (let ((res (yy-ref-table (car form))))
	(assert res)
	(apply res (cdr form)))))

(defmacro yy-setf (&rest form)
  (if (/= (logand (length form) 1) 0)
      (error "yy-setf: Wrong-number-of-arguments(~A)" (length form)))
  (if (and form (null (cddr form)))
      (let ((place (pop form))
	    (val (car form)))
	(if (symbolp place) `(setq ,place ,val)
	    (multiple-value-bind
		  (vars fms value-var storing access) (yy-gse place)
	      `(let* (,@(mapcar #'list vars fms)
		      (,(car value-var) ,val))
		 ,storing))))
      (let ((sets nil))
	(prog ()
	 it
	   (push `(setf ,(pop form) ,(pop form)) sets)
	   (when form (go it)))
	(cons 'progn (nreverse sets)))))

(defmacro yy-ds (symbol function-or-ls &optional store-var &rest form)
  (if (not (symbolp function-or-ls)) (error "yy-ds: not symbol")
      (let ((fun function-or-ls))
	`(yy-dse ,symbol (&rest x)
		 (assert x)
		 (let ((vs (mapcar (lambda (x) (gensym)) x))
		       (g (gensym)))
		   (values vs x `(,g) `(funcall #',',fun ,@vs ,g) `(,',symbol ,@vs)))))))

(defmacro yy-dmm (name arglist func)
  (let* ((arglist-1 (cons 'obj arglist)))
    `(defmacro ,name ,arglist-1
       (multiple-value-bind (vs fs val st as) (yy-gse obj)
	 `(let* (,@(mapcar #'list vs fs)
		 (,(car val) ,as))
	    (setq ,(car val) (funcall #',',func ,(car val) ,,@arglist))
	    ,st)))))