From 93a48dc177c1509396980002910124d70aaa4089 Mon Sep 17 00:00:00 2001 From: =?utf8?q?David=20V=C3=A1zquez?= Date: Thu, 20 Feb 2014 01:20:37 +0100 Subject: [PATCH] Move SETF to src/setf.lisp --- jscl.lisp | 1 + src/boot.lisp | 111 ------------------------------------------------- src/setf.lisp | 129 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 130 insertions(+), 111 deletions(-) create mode 100644 src/setf.lisp diff --git a/jscl.lisp b/jscl.lisp index e3a9581..e21ab3d 100644 --- a/jscl.lisp +++ b/jscl.lisp @@ -41,6 +41,7 @@ (defvar *source* '(("boot" :target) ("compat" :host) + ("setf" :target) ("utils" :both) ("numbers" :target) ("char" :target) diff --git a/src/boot.lisp b/src/boot.lisp index a45bb73..ce61f98 100644 --- a/src/boot.lisp +++ b/src/boot.lisp @@ -353,117 +353,6 @@ `(multiple-value-call #'list ,value-from)) -;;; 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))))))) - -(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)))))) - - - ;; Incorrect typecase, but used in NCONC. (defmacro typecase (x &rest clausules) (let ((value (gensym))) 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)))))) -- 1.7.10.4