/[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.12 by pfdietz, Mon Sep 5 15:30:48 2005 UTC revision 1.13 by camm, Sun Sep 18 02:46:35 2005 UTC
# Line 39  Line 39 
39  (in-package 'system)  (in-package 'system)
40    
41    
42  (eval-when (compile) (proclaim '(optimize (safety 2) (space 3))))  ;(eval-when (compile) (proclaim '(optimize (safety 2) (space 3))))
43  (eval-when (eval compile) (defun si:clear-compiler-properties (symbol)))  (eval-when (eval compile) (defun si:clear-compiler-properties (symbol)))
44  (eval-when (eval compile) (setq si:*inhibit-macro-special* nil))  (eval-when (eval compile) (setq si:*inhibit-macro-special* nil))
45    
46    
47  ;;; DEFSETF macro.  ;;; DEFSETF macro.
48  (defmacro defsetf (access-fn &rest rest)  (defmacro defsetf (access-fn &rest rest)
49      (declare (optimize (safety 1)))
50    (cond ((and (car rest) (or (symbolp (car rest)) (functionp (car rest))))    (cond ((and (car rest) (or (symbolp (car rest)) (functionp (car rest))))
51           `(eval-when(compile eval load)           `(eval-when(compile eval load)
52                   (si:putprop ',access-fn ',(car rest) 'setf-update-fn)                   (si:putprop ',access-fn ',(car rest) 'setf-update-fn)
# Line 93  Line 94 
94            ',access-fn))            ',access-fn))
95    
96  (defmacro define-setf-expander (access-fn &rest rest)  (defmacro define-setf-expander (access-fn &rest rest)
97      (declare (optimize (safety 1)))
98    `(define-setf-method ,access-fn ,@rest))    `(define-setf-method ,access-fn ,@rest))
99    
100  ;;; GET-SETF-METHOD.  ;;; GET-SETF-METHOD.
# Line 106  Line 108 
108      (values vars vals stores store-form access-form)))      (values vars vals stores store-form access-form)))
109    
110  (defun get-setf-expansion (form &optional env)  (defun get-setf-expansion (form &optional env)
111      (declare (optimize (safety 1)))
112    (get-setf-method form env))    (get-setf-method form env))
113    
114  ;;;; GET-SETF-METHOD-MULTIPLE-VALUE.  ;;;; GET-SETF-METHOD-MULTIPLE-VALUE.
# Line 410  Line 413 
413  ;;; PSETF macro.  ;;; PSETF macro.
414    
415  (defmacro psetf (&environment env &rest rest)  (defmacro psetf (&environment env &rest rest)
416      (declare (optimize (safety 1)))
417    (cond ((endp rest) nil)    (cond ((endp rest) nil)
418          ((endp (cdr rest)) (error "~S is an illegal PSETF form." rest))          ((endp (cdr rest)) (error "~S is an illegal PSETF form." rest))
419          ((endp (cddr rest))          ((endp (cddr rest))
# Line 437  Line 441 
441    
442  ;;; SHIFTF macro.  ;;; SHIFTF macro.
443  (defmacro shiftf (&environment env &rest rest )  (defmacro shiftf (&environment env &rest rest )
444      (declare (optimize (safety 1)))
445    (do ((r rest (cdr r))    (do ((r rest (cdr r))
446         (pairs nil)         (pairs nil)
447         (stores nil)         (stores nil)
# Line 463  Line 468 
468    
469  ;;; ROTATEF macro.  ;;; ROTATEF macro.
470  (defmacro rotatef (&environment env &rest rest )  (defmacro rotatef (&environment env &rest rest )
471      (declare (optimize (safety 1)))
472    (do ((r rest (cdr r))    (do ((r rest (cdr r))
473         (pairs nil)         (pairs nil)
474         (stores nil)         (stores nil)
# Line 496  Line 502 
502  ;;; DEFINE-MODIFY-MACRO macro.  ;;; DEFINE-MODIFY-MACRO macro.
503  ;;FIXME -- this is really upgly and error prone.  CM 20041214  ;;FIXME -- this is really upgly and error prone.  CM 20041214
504  (defmacro define-modify-macro (name lambda-list function &optional doc-string)  (defmacro define-modify-macro (name lambda-list function &optional doc-string)
505      (declare (optimize (safety 1)))
506    (let ((update-form    (let ((update-form
507           (do ((l lambda-list (cdr l))           (do ((l lambda-list (cdr l))
508                (vs nil))                (vs nil))
# Line 537  Line 544 
544    
545  ;;; This definition was obtained from SBCL  ;;; This definition was obtained from SBCL
546  (defmacro remf (&environment env place indicator)  (defmacro remf (&environment env place indicator)
547      (declare (optimize (safety 1)))
548    (multiple-value-bind (dummies vals newval setter getter)    (multiple-value-bind (dummies vals newval setter getter)
549        (get-setf-method place env)        (get-setf-method place env)
550      (do* ((d dummies (cdr d))      (do* ((d dummies (cdr d))
# Line 568  Line 576 
576  (define-modify-macro decf (&optional (delta 1)) -)  (define-modify-macro decf (&optional (delta 1)) -)
577    
578  (defmacro push (&environment env item place)  (defmacro push (&environment env item place)
579      (declare (optimize (safety 1)))
580    (let ((myitem (gensym)))    (let ((myitem (gensym)))
581      (when (symbolp place)      (when (symbolp place)
582        (return-from push `(let* ((,myitem ,item))        (return-from push `(let* ((,myitem ,item))
# Line 580  Line 589 
589                              ,store-form))))                              ,store-form))))
590    
591  (defmacro pushnew (&environment env item place &rest rest)  (defmacro pushnew (&environment env item place &rest rest)
592      (declare (optimize (safety 1)))
593    (let ((myitem (gensym)))    (let ((myitem (gensym)))
594      (cond ((symbolp place)      (cond ((symbolp place)
595             (return-from pushnew `(let* ((,myitem ,item))             (return-from pushnew `(let* ((,myitem ,item))
# Line 593  Line 603 
603                              ,store-form))))                              ,store-form))))
604    
605  (defmacro pop (&environment env place)  (defmacro pop (&environment env place)
606      (declare (optimize (safety 1)))
607    (when (symbolp place)    (when (symbolp place)
608          (return-from pop          (return-from pop
609            (let ((temp (gensym)))            (let ((temp (gensym)))
# Line 608  Line 619 
619                ,store-form))))                ,store-form))))
620    
621  (defun (setf fdefinition) (def fn)  (defun (setf fdefinition) (def fn)
622      (declare (optimize (safety 1)))
623    (when (not (functionp def))    (when (not (functionp def))
624      (specific-error :wrong-type-argument "~S is not of type ~S~%" def 'function))      (specific-error :wrong-type-argument "~S is not of type ~S~%" def 'function))
625    (cond ((symbolp fn)    (cond ((symbolp fn)

Legend:
Removed from v.1.12  
changed lines
  Added in v.1.13

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