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) |
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. |
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. |
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)) |
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) |
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) |
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)) |
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)) |
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)) |
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)) |
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))) |
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) |