/[gcl]/gcl/lsp/gcl_setf.lsp
ViewVC logotype

Diff of /gcl/lsp/gcl_setf.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.6 by camm, Mon Nov 22 22:03:22 2004 UTC revision 1.7 by camm, Fri Dec 17 21:31:55 2004 UTC
# Line 472  Line 472 
472        (setq access-forms (cons access-form access-forms)))))        (setq access-forms (cons access-form access-forms)))))
473    
474    
475    (defun make-update-form (function access-form others lets)
476      (if others
477          (make-update-form function access-form (cdr others)
478                            (cons (list 'list (list 'quote (gensym)) (car others)) lets))
479        `(list 'let* (list ,@lets)
480               (list ',function access-form ,@(mapcar (lambda (x) (list 'quote (cadadr x))) lets)))))
481    
482  ;;; DEFINE-MODIFY-MACRO macro.  ;;; DEFINE-MODIFY-MACRO macro.
483    ;;FIXME -- this is really upgly and error prone.  CM 20041214
484  (defmacro define-modify-macro (name lambda-list function &optional doc-string)  (defmacro define-modify-macro (name lambda-list function &optional doc-string)
485    (let ((update-form    (let ((update-form
486           (do ((l lambda-list (cdr l))           (do ((l lambda-list (cdr l))
487                (vs nil))                (vs nil))
488               ((null l) `(list ',function access-form ,@(nreverse vs)))               ((null l) (make-update-form function 'access-form (nreverse vs) nil))
489             (unless (eq (car l) '&optional)             (unless (eq (car l) '&optional)
490                     (if (eq (car l) '&rest)                     (if (eq (car l) '&rest)
491                         (return `(list* ',function                         (return `(list* ',function

Legend:
Removed from v.1.6  
changed lines
  Added in v.1.7

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26