Skip to content

Instantly share code, notes, and snippets.

@include-yy
Last active September 2, 2023 10:57
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save include-yy/dddaba707bfeebb177f0bfba06056097 to your computer and use it in GitHub Desktop.
Save include-yy/dddaba707bfeebb177f0bfba06056097 to your computer and use it in GitHub Desktop.
simple Common Lisp gv feature

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

(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)))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment