home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / LISP / PDLISP.ZIP / SETF.L < prev    next >
Encoding:
Text File  |  1986-07-30  |  7.2 KB  |  264 lines
  1. ;;;
  2. ;;; SETF.L - Copyright (c) 1986 by David Morein
  3. ;;;
  4. ;;; This file contains all code relevent to SETF and DEFSETF.
  5. ;;;
  6. (pdq /sys/cmd)
  7. ;;;
  8. (global 'setf 'get-setf-method 'define-setf-method)
  9. ;;;
  10. ;;; SETF is taken from Steele, p107. It is an implementation
  11. ;;; of a subset of the SETF standard.
  12. ;;;
  13. (defmacro setf (reference value)
  14.     (multiple-value-bind (vars vals stores store-form access-form)
  15.         (get-setf-method reference)
  16.         `(let* ,(mapcar 'list
  17.                 (append vars stores)
  18.                 (append vals (list value)))
  19.             ,store-form)))
  20. ;;;
  21. ;;; GET-SETF-METHOD - retrieves the quintuple constituting
  22. ;;; the setf method for FORM. If FORM is atomic (i.e., a symbol),
  23. ;;; then a method is computed for it by ATOMIC-METHOD; otherwise
  24. ;;; the method generator corresponding to FORM is retrieved
  25. ;;; from the property list of SETF, and evaluated to produce
  26. ;;; a method. The property list of SETF is organized by access-fn;
  27. ;;; under each function name is a value which is the method generator
  28. ;;; for that function.
  29. ;;;
  30. (defun get-setf-method (reference)
  31.     (if (atom reference)
  32.         (atomic-method reference)
  33.         (progn
  34.             (setq let-vars
  35.                 (mapcar 'list
  36.                   (get 'setf-lambda-lists (car reference))
  37.                 (mapcar 'quote (cdr reference))))
  38.             (eval (eval
  39.               `(let ,let-vars ,(get 'setf (car reference))))))))
  40. ;;;
  41. ;;; ATOMIC-METHOD - standard setf method for an atomic reference
  42. ;;;
  43. (defmacro atomic-method (variable)
  44.     `(if (symbolp ,variable)
  45.       (let    ((store-variable ',(gensym)))
  46.         (values    
  47.             '()
  48.             '()
  49.             '(store-variable)
  50.             '(setq ,variable store-variable)
  51.             '(,variable)))
  52.       (err "***> SETF: constant cannot be setq'd.")))
  53. ;;;
  54. ;;; DEFINE-SETF-METHOD - stores the setf method for a
  55. ;;; generalized variable reference.
  56. ;;;
  57. (defmacro define-setf-method (access-fn lambda-list &rest body)
  58.     `(progn
  59.         (putprop 'setf-lambda-lists ',lambda-list ',access-fn)
  60.         (putprop 'setf ',body ',access-fn)))
  61. ;;;
  62. ;;; METHOD-BROWSE - constructs a sample method for a generalized
  63. ;;; variable reference, and displays it. For example,
  64. ;;; (METHOD-BROWSE '(car y)) might produce the output:
  65. ;;;
  66. ;;; reference   = (CAR _Y)
  67. ;;; vars        = (G9)
  68. ;;; vals        = (_Y)
  69. ;;; stores      = (G10)
  70. ;;; store-form  = (PROGN (RPLACA G9 G10) G10)
  71. ;;; access-form = (CAR G9)
  72. ;;;
  73. (defun method-browse (reference)
  74.     (multiple-value-bind (vars vals stores store-form access-form)
  75.     (get-setf-method reference)
  76.     (princ "reference   = ") (print reference) (terpri)
  77.     (princ "vars        = ") (print vars) (terpri)
  78.     (princ "vals        = ") (print vals) (terpri)
  79.     (princ "stores      = ") (print stores) (terpri)
  80.     (princ "store-form  = ") (print store-form) (terpri)
  81.     (princ "access-form = ") (print access-form) (terpri)
  82.     ))
  83. ;;;
  84. ;;; some methods for common functions:
  85. ;;;
  86. ;;; the following example is from Steele, p106
  87. ;;;
  88. (define-setf-method ldb (bytespec int)
  89.   (multiple-value-bind (temps vals stores store-form access-form)
  90.     (get-setf-method int)    ;get SETF method for int.
  91.   (let ((btemp (gensym))    ;temp var for byte specifier.
  92.       (store (gensym))    ;temp var for byte to store.    
  93.     (stemp (first stores)))    ;temp var for int to store.
  94.     ;; Return the SETF method for LDB as five values.
  95.     (values (cons btemp temps)        ;temporary variables.
  96.             (cons bytespec vals)    ;value forms.
  97.         (list store)        ;store variables.
  98.         `(let ((,stemp (dpb ,store ,btemp ,access-form)))
  99.             ,store-form
  100.         ,store)            ;storing form.
  101.         `(ldb ,btemp ,access-form)    ;accessing form.
  102.         ))))
  103.  
  104. ;;;
  105. ;;; other SETF methods:
  106. ;;;
  107. ;;; method for CAR
  108. ;;;
  109. (define-setf-method car (x)
  110.     (let ((store-var1 (gensym)) (store-var2 (gensym)))
  111.     `(values
  112.         ',(list store-var1)
  113.         '(,x)
  114.         ',(list store-var2)
  115.         '(progn (rplaca ,store-var1 ,store-var2) ,store-var2)
  116.         '(car ,store-var1))))
  117. ;;;
  118. ;;; method for CDR
  119. ;;;
  120. (define-setf-method cdr (x)
  121.     (let ((store-var1 (gensym)) (store-var2 (gensym)))
  122.     `(values
  123.         ',(list store-var1)
  124.         '(,x)
  125.         ',(list store-var2)
  126.         '(progn (rplacd ,store-var1 ,store-var2) ,store-var2)
  127.         '(cdr ,store-var1))))
  128. ;;;
  129. ;;; method for CAAR
  130. ;;;
  131. (define-setf-method caar (x)
  132.     (let ((store-var1 (gensym)) (store-var2 (gensym)))
  133.     `(values
  134.         ',(list store-var1)
  135.         '(,x)
  136.         ',(list store-var2)
  137.         '(progn (rplaca (car ,store-var1) ,store-var2) ,store-var2)
  138.         '(caar ,store-var1))))
  139. ;;;
  140. ;;; method for CADR
  141. ;;;
  142. (define-setf-method cadr (x)
  143.     (let ((store-var1 (gensym)) (store-var2 (gensym)))
  144.     `(values
  145.         ',(list store-var1)
  146.         '(,x)
  147.         ',(list store-var2)
  148.         '(progn (rplaca (cdr ,store-var1) ,store-var2) ,store-var2)
  149.         '(cadr ,store-var1))))
  150. ;;;
  151. ;;; method for CDAR
  152. ;;;
  153. (define-setf-method cdar (x)
  154.     (let ((store-var1 (gensym)) (store-var2 (gensym)))
  155.     `(values
  156.         ',(list store-var1)
  157.         '(,x)
  158.         ',(list store-var2)
  159.         '(progn (rplacd (car ,store-var1) ,store-var2) ,store-var2)
  160.         '(cdar ,store-var1))))
  161. ;;;
  162. ;;; method for CDDR
  163. ;;;
  164. (define-setf-method cddr (x)
  165.     (let ((store-var1 (gensym)) (store-var2 (gensym)))
  166.     `(values
  167.         ',(list store-var1)
  168.         '(,x)
  169.         ',(list store-var2)
  170.         '(progn (rplacd (cdr ,store-var1) ,store-var2) ,store-var2)
  171.         '(cddr ,store-var1))))
  172. ;;;
  173. ;;; method for CAAAR
  174. ;;;
  175. (define-setf-method caaar (x)
  176.     (let ((store-var1 (gensym)) (store-var2 (gensym)))
  177.     `(values
  178.         ',(list store-var1)
  179.         '(,x)
  180.         ',(list store-var2)
  181.         '(progn (rplaca (caar ,store-var1) ,store-var2) ,store-var2)
  182.         '(caaar ,store-var1))))
  183. ;;;
  184. ;;; method for CAADR
  185. ;;;
  186. (define-setf-method caadr (x)
  187.     (let ((store-var1 (gensym)) (store-var2 (gensym)))
  188.     `(values
  189.         ',(list store-var1)
  190.         '(,x)
  191.         ',(list store-var2)
  192.         '(progn (rplaca (cadr ,store-var1) ,store-var2) ,store-var2)
  193.         '(caadr ,store-var1))))
  194. ;;;
  195. ;;; method for CADAR
  196. ;;;
  197. (define-setf-method cadar (x)
  198.     (let ((store-var1 (gensym)) (store-var2 (gensym)))
  199.     `(values
  200.         ',(list store-var1)
  201.         '(,x)
  202.         ',(list store-var2)
  203.         '(progn (rplaca (cdar ,store-var1) ,store-var2) ,store-var2)
  204.         '(cadar ,store-var1))))
  205. ;;;
  206. ;;; method for CADDR
  207. ;;;
  208. (define-setf-method caddr (x)
  209.     (let ((store-var1 (gensym)) (store-var2 (gensym)))
  210.     `(values
  211.         ',(list store-var1)
  212.         '(,x)
  213.         ',(list store-var2)
  214.         '(progn (rplaca (cddr ,store-var1) ,store-var2) ,store-var2)
  215.         '(caddr ,store-var1))))
  216. ;;;
  217. ;;; method for CDAAR
  218. ;;;
  219. (define-setf-method cdaar (x)
  220.     (let ((store-var1 (gensym)) (store-var2 (gensym)))
  221.     `(values
  222.         ',(list store-var1)
  223.         '(,x)
  224.         ',(list store-var2)
  225.         '(progn (rplacd (caar ,store-var1) ,store-var2) ,store-var2)
  226.         '(cdaar ,store-var1))))
  227. ;;;
  228. ;;; method for CDADR
  229. ;;;
  230. (define-setf-method cdadr (x)
  231.     (let ((store-var1 (gensym)) (store-var2 (gensym)))
  232.     `(values
  233.         ',(list store-var1)
  234.         '(,x)
  235.         ',(list store-var2)
  236.         '(progn (rplacd (cadr ,store-var1) ,store-var2) ,store-var2)
  237.         '(cdadr ,store-var1))))
  238. ;;;
  239. ;;; method for CDDAR
  240. ;;;
  241. (define-setf-method cddar (x)
  242.     (let ((store-var1 (gensym)) (store-var2 (gensym)))
  243.     `(values
  244.         ',(list store-var1)
  245.         '(,x)
  246.         ',(list store-var2)
  247.         '(progn (rplacd (cdar ,store-var1) ,store-var2) ,store-var2)
  248.         '(cddar ,store-var1))))
  249. ;;;
  250. ;;;
  251. ;;; method for CDDDR
  252. ;;;
  253. (define-setf-method cdddr (x)
  254.     (let ((store-var1 (gensym)) (store-var2 (gensym)))
  255.     `(values
  256.         ',(list store-var1)
  257.         '(,x)
  258.         ',(list store-var2)
  259.         '(progn (rplacd (cddr ,store-var1) ,store-var2) ,store-var2)
  260.         '(cdddr ,store-var1))))
  261. ;;;
  262. (popd)    ;return to original directory
  263.  
  264.