X-Git-Url: http://repo.macrolet.net/gitweb/?p=jscl.git;a=blobdiff_plain;f=src%2Fsetf.lisp;fp=src%2Fsetf.lisp;h=fc0888252feabdff8d7451ed49dd8805e5e60701;hp=0000000000000000000000000000000000000000;hb=93a48dc177c1509396980002910124d70aaa4089;hpb=a2bb848e0037e127287781e99528bc4e93ccc2fb diff --git a/src/setf.lisp b/src/setf.lisp new file mode 100644 index 0000000..fc08882 --- /dev/null +++ b/src/setf.lisp @@ -0,0 +1,129 @@ +;;; setf.lisp --- + +;; JSCL is free software: you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; JSCL is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with JSCL. If not, see . + + +;;; Generalized references (SETF) + +(eval-when(:compile-toplevel :load-toplevel :execute) + (defvar *setf-expanders* nil) + (defun !get-setf-expansion (place) + (if (symbolp place) + (let ((value (gensym))) + (values nil + nil + `(,value) + `(setq ,place ,value) + place)) + (let ((place (!macroexpand-1 place))) + (let* ((access-fn (car place)) + (expander (cdr (assoc access-fn *setf-expanders*)))) + (when (null expander) + (error "Unknown generalized reference.")) + (apply expander (cdr place))))))) +(fset 'get-setf-expansion (fdefinition '!get-setf-expansion)) + +(defmacro define-setf-expander (access-fn lambda-list &body body) + (unless (symbolp access-fn) + (error "ACCESS-FN `~S' must be a symbol." access-fn)) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (push (cons ',access-fn (lambda ,lambda-list ,@body)) + *setf-expanders*) + ',access-fn)) + +(defmacro setf (&rest pairs) + (cond + ((null pairs) + nil) + ((null (cdr pairs)) + (error "Odd number of arguments to setf.")) + ((null (cddr pairs)) + (let ((place (!macroexpand-1 (first pairs))) + (value (second pairs))) + (multiple-value-bind (vars vals store-vars writer-form reader-form) + (!get-setf-expansion place) + (declare (ignorable reader-form)) + ;; TODO: Optimize the expansion a little bit to avoid let* + ;; or multiple-value-bind when unnecesary. + `(let* ,(mapcar #'list vars vals) + (multiple-value-bind ,store-vars + ,value + ,writer-form))))) + (t + `(progn + ,@(do ((pairs pairs (cddr pairs)) + (result '() (cons `(setf ,(car pairs) ,(cadr pairs)) result))) + ((null pairs) + (reverse result))))))) + + + + +;;; SETF-Based macros + +(defmacro incf (place &optional (delta 1)) + (multiple-value-bind (dummies vals newval setter getter) + (!get-setf-expansion place) + (let ((d (gensym))) + `(let* (,@(mapcar #'list dummies vals) + (,d ,delta) + (,(car newval) (+ ,getter ,d)) + ,@(cdr newval)) + ,setter)))) + +(defmacro decf (place &optional (delta 1)) + (multiple-value-bind (dummies vals newval setter getter) + (!get-setf-expansion place) + (let ((d (gensym))) + `(let* (,@(mapcar #'list dummies vals) + (,d ,delta) + (,(car newval) (- ,getter ,d)) + ,@(cdr newval)) + ,setter)))) + +(defmacro push (x place) + (multiple-value-bind (dummies vals newval setter getter) + (!get-setf-expansion place) + (let ((g (gensym))) + `(let* ((,g ,x) + ,@(mapcar #'list dummies vals) + (,(car newval) (cons ,g ,getter)) + ,@(cdr newval)) + ,setter)))) + +(defmacro pop (place) + (multiple-value-bind (dummies vals newval setter getter) + (!get-setf-expansion place) + (let ((head (gensym))) + `(let* (,@(mapcar #'list dummies vals) + (,head ,getter) + (,(car newval) (cdr ,head)) + ,@(cdr newval)) + ,setter + (car ,head))))) + +(defmacro pushnew (x place &rest keys &key key test test-not) + (declare (ignore key test test-not)) + (multiple-value-bind (dummies vals newval setter getter) + (!get-setf-expansion place) + (let ((g (gensym)) + (v (gensym))) + `(let* ((,g ,x) + ,@(mapcar #'list dummies vals) + ,@(cdr newval) + (,v ,getter)) + (if (member ,g ,v ,@keys) + ,v + (let ((,(car newval) (cons ,g ,getter))) + ,setter))))))