From 3777c03f92d1cbb69b2ecb13ba57817c00fe2795 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Wed, 7 Apr 2004 15:30:06 +0000 Subject: [PATCH] A VALUES form can now act as a place --- src/CHANGELOG | 2 + src/lsp/setf.lsp | 98 +++++++++++++++++++++++++++--------------------- 2 files changed, 58 insertions(+), 42 deletions(-) diff --git a/src/CHANGELOG b/src/CHANGELOG index eb6dd3b6b..99aa4d6b0 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -1847,6 +1847,8 @@ ECL 0.9d - Streams now can have element types CHARACTER, (SIGNED-BYTE 8) and (UNSIGNED-BYTE 8). + - A VALUES form can now act as a place. + TODO: ===== diff --git a/src/lsp/setf.lsp b/src/lsp/setf.lsp index da75eff09..44a57c5d3 100644 --- a/src/lsp/setf.lsp +++ b/src/lsp/setf.lsp @@ -12,6 +12,10 @@ (in-package "SYSTEM") +(defun check-stores-number (context stores-list n) + (unless (= (length stores-list) n) + (error "~d store-variables expected in setf form ~a." n context))) + ;;; DEFSETF macro. (defmacro defsetf (access-fn &rest rest) "Syntax: (defsetf symbol update-fun [doc]) @@ -39,8 +43,7 @@ by (documentation 'SYMBOL 'setf)." (args (first rest)) (body (cddr rest)) (doc (find-documentation body))) - (unless (and (= (list-length store) 1) (symbolp (first store))) - (error "Single store-variable expected.")) + (check-stores-number 'DEFSETF store 1) (setq rest `(lambda ,args #'(lambda ,store ,@body))) `(eval-when (compile load eval) (put-sysprop ',access-fn 'SETF-LAMBDA #'(lambda (,@store ,@args) ,@body)) @@ -91,23 +94,9 @@ by (DOCUMENTATION 'SYMBOL 'SETF)." ',access-fn)) -;;; GET-SETF-METHOD. -;;; It just calls GET-SETF-METHOD-MULTIPLE-VALUE -;;; and checks the number of the store variable. -(defun get-setf-expansion (form &optional env) - "Args: (place) -Returns the 'five gangs' (see DEFINE-SETF-EXPANDER) for PLACE as five values. -Checks if the third gang is a single-element list." - (multiple-value-bind (vars vals stores store-form access-form) - (get-setf-method-multiple-value form env) - (unless (= (list-length stores) 1) - (error "Multiple store-variables are not allowed.")) - (values vars vals stores store-form access-form))) +;;;; get-setf-expansion. - -;;;; GET-SETF-METHOD-MULTIPLE-VALUE. - -(defun get-setf-method-multiple-value (form &optional env &aux f) +(defun get-setf-expansion (form &optional env &aux f) "Args: (form) Returns the 'five gangs' (see DEFINE-SETF-EXPANDER) for PLACE as five values. Does not check if the third gang is a single-element list." @@ -121,7 +110,7 @@ Does not check if the third gang is a single-element list." (values (gensym) (nreverse names) (nreverse values) (nreverse all-args)))) (cond ((symbolp form) (if (and (setq f (macroexpand form env)) (not (equal f form))) - (get-setf-method-multiple-value f env) + (get-setf-expansion f env) (let ((store (gensym))) (values nil nil (list store) `(setq ,form ,store) form)))) ((or (not (consp form)) (not (symbolp (car form)))) @@ -140,8 +129,8 @@ Does not check if the third gang is a single-element list." ((setq f (get-sysprop (car form) 'SETF-LAMBDA)) (apply f store all)) ((and (setq f (macroexpand form env)) (not (equal f form))) - (return-from get-setf-method-multiple-value - (get-setf-method-multiple-value f env))) + (return-from get-setf-expansion + (get-setf-expansion f env))) (t `(funcall #'(SETF ,name) ,store ,@all)))) (values vars inits (list store) writer (cons name all)))))))) @@ -308,11 +297,17 @@ Does not check if the third gang is a single-element list." (multiple-value-bind (vars vals stores store-form access-form) (get-setf-expansion place env) (declare (ignore access-form)) - `(let* ,(mapcar #'list - (append vars stores) - (append vals (list newvalue))) - (declare (:read-only ,@ (append vars stores))) ; Beppe - ,store-form))) + (let ((declaration `(declare (:read-only ,@(append vars stores))))) + (if (= (length stores) 1) + `(let* ,(mapcar #'list + (append vars stores) + (append vals (list newvalue))) + ,declaration + ,store-form) + `(let* ,(mapcar #'list vars vals) + (multiple-value-bind ,stores ,newvalue + ,declaration + ,store-form)))))) (defun setf-structure-access (struct type index newvalue) (declare (si::c-local)) @@ -566,10 +561,10 @@ Decrements the value of PLACE by the value of FORM. FORM defaults to 1.") "Syntax: (push form place) Evaluates FORM, conses the value of FORM to the value stored in PLACE, and makes it the new value of PLACE. Returns the new value of PLACE." - (when (symbolp place) - (return-from push `(setq ,place (cons ,item ,place)))) (multiple-value-bind (vars vals stores store-form access-form) (get-setf-expansion place env) + (when (and (null vars) (eq access-form place)) + (return-from push `(setq ,place (cons ,item ,place)))) ;; The item to be pushed has to be evaluated before the destination (unless (constantp item) (setq vals (cons item vals) @@ -588,10 +583,10 @@ does nothing. Else, conses the value onto the list and makes the result the new value of PLACE. Returns NIL. KEYWORD-FORMs and VALUE-FORMs are used to check if the value of FORM is already in PLACE as if their values are passed to MEMBER." - (cond ((symbolp place) - (return-from pushnew `(setq ,place (adjoin ,item ,place ,@rest))))) (multiple-value-bind (vars vals stores store-form access-form) (get-setf-expansion place env) + (when (and (null vars) (eq access-form place)) + (return-from pushnew `(setq ,place (adjoin ,item ,place ,@rest)))) ;; The item to be pushed has to be evaluated before the destination (unless (constantp item) (setq vals (cons item vals) @@ -608,20 +603,39 @@ to MEMBER." "Syntax: (pop place) Gets the cdr of the value stored in PLACE and makes it the new value of PLACE. Returns the car of the old value in PLACE." - (when (symbolp place) - (return-from pop - (let ((temp (gensym))) - `(let ((,temp (car ,place))) - (setq ,place (cdr ,place)) - ,temp)))) (multiple-value-bind (vars vals stores store-form access-form) (get-setf-expansion place env) - `(let* ,(mapcar #'list - (append vars stores) - (append vals (list (list 'cdr access-form)))) - (declare (:read-only ,@vars)) ; Beppe - (prog1 (car ,access-form) - ,store-form)))) + (if (and (null vars) (eq access-form place)) + `(prog1 (car ,place) (setq ,place (cdr ,place))) + `(let* ,(mapcar #'list + (append vars stores) + (append vals (list (list 'cdr access-form)))) + (declare (:read-only ,@vars)) ; Beppe + (prog1 (car ,access-form) + ,store-form))))) + +(define-setf-expander values (&rest values &environment env) + (let ((vars '()) + (vals '()) + (stores '()) + (storing-form '()) + (get-form '())) + (dolist (item (nreverse values)) + (multiple-value-bind (v vr s sf gf) + (get-setf-expansion item) + ;; If a place has more than one store variable, the other ones + ;; are set to nil. + (let ((extra (rest s))) + (unless (endp extra) + (setf vars (append endp vars) + vals (append (make-list (length s)) vals) + s (list (first s))))) + (setf vars (append vr vars) + vals (append v vals) + stores (append s stores) + storing-form (cons sf storing-form) + get-form (cons gf get-form)))) + (values vars vals stores `(values ,@storing-form) `(values ,@get-form)))) #| ;;; Proposed extension: ; Expansion of (SETF (VALUES place1 ... placek) form)