source: trunk/lisp/lispm2/nstruc.lisp @ 245

Last change on this file since 245 was 245, checked in by rjs, 3 years ago

Update.

File size: 26.3 KB
Line 
1;; New DEFSTRUCT.                       ALAN & DLW 12/11/77 -*-LISP-*-
2;       ** (c) Copyright 1980 Massachusetts Institute of Technology **
3;; CAUTION! This file must be compilable both by NCOMPLR and by QC; be quite
4;;    careful not to use anything which is dependent on one or the other Lisp dialect.
5
6(DECLARE (COND ((STATUS FEATURE LISPM))
7               ((NULL (MEMQ 'NEWIO (STATUS FEATURES)))
8                (BREAK 'YOU-HAVE-TO-COMPILE-THIS-WITH-QCOMPL T))
9               ((NULL (GET 'IF-FOR-MACLISP 'MACRO))
10                (LOAD '(MACROS > DSK LISPM))
11                (LOAD '(DEFMAC FASL DSK LISPM2))
12                (LOAD '(LMMAC > DSK LISPM2))
13                (MACROS T))))   ;SEND OVER THE REST OF THE MACROS IN THIS FILE
14
15(DECLARE (SETQ RUN-IN-MACLISP-SWITCH T))
16
17(IF-FOR-MACLISP (SETSYNTAX '/: '/  NIL)) ;Ignore colon prefixes in Maclisp
18
19;; This still needs some more hair, for optimization of the simple cases of the
20;; constructor macros.
21
22;;; The bullshit in here with the SUBST and so forth is temporary to
23;;; fix problems with temporary-area lossage in the compiler
24;;; This will still lose if there are strings in inits in the temporary
25;;; area, but it will at least avoid putting properties which are whole
26;;; lists consed up in the temporary area, which should alleviate the
27;;; symptoms for now.
28(DEFMACRO DEFSTRUCT-PUTPROP (SYM VAL IND)
29  `(PROGN
30      ,(AND (SYMBOLP VAL) (NEQ VAL T) (NEQ VAL NIL)  ;VAL is a variable
31            `(AND (NOT (ATOM ,VAL))
32                  (NEQ (%AREA-NUMBER ,VAL) WORKING-STORAGE-AREA)
33                  (SETQ ,VAL (SUBST NIL NIL ,VAL))))
34      (PUSH `(PUTPROP ',,SYM ',,VAL ',,IND) RETURNS)
35      (PUTPROP ,SYM ,VAL ,IND)))
36
37(DEFMACRO DEFSTRUCT ((NAME . OPTIONS) . ITEMS)
38    (DEFSTRUCT-1 NAME OPTIONS ITEMS))
39
40;; Returns a list of the form (PROGN 'COMPILE ...)
41(DEFUN DEFSTRUCT-1 (NAME OPTIONS ITEMS)
42  (LET ((TYPE NIL)              ;ARRAY, ARRAY-LEADER, or LIST.
43        (GROUPED-P NIL)         ;NIL or T
44        (SIZE-SYMBOL NIL)
45        (SIZE-MACRO NIL)
46        (CONSTRUCTOR T)         ;NIL for none at all, T for generated name, else name.
47        (NAMED-STRUCTURE-P NIL) ;If T, NAMED option was specified
48        (DEFAULT-POINTER NIL)
49        (INCLUDE NIL)           ;Name of DEFSTRUCT to include.
50
51        (OFFSET 0)              ;Number of reserved words at beginning.
52        (TEM NIL)               ;Random temporary.
53        (SIZE NIL)              ;Size of this DEFSTRUCT.
54        (RETURNS NIL)           ;The list which we return.
55        (ITEM-LIST NIL)         ;A list of names of access macros.
56        (INIT-LIST NIL)         ;The initialization for each.
57        (CONSTRUCTOR-ARRAY-OP NIL)      ;MAKE-ARRAY-DEFAULT parameter.
58        (CONSTRUCTOR-TIMES-OP NIL)      ;GROUPED-ARRAY parameter.
59        (NOINIT NIL)            ;Set if initalization not allowed (types %P-LDB and FIXNUM).
60        )
61    (PUSH `',NAME RETURNS)
62    (DO ((OPL OPTIONS (CDR OPL))
63         (OP)
64         (OPARGS)
65         (OPSOFAR NIL (CONS OP OPSOFAR)))
66        ((NULL OPL))
67      (SETQ OP (CAR OPL))
68      (COND ((EQ (TYPEP OP) 'LIST)
69             (SETQ OPARGS (CDR OP) OP (CAR OP)))
70            (T (SETQ OPARGS NIL)))
71      (AND (MEMQ OP OPSOFAR)
72           (ERROR '|This optional was given more than once -- DEFSTRUCT| OPTIONS))
73      (SELECTQ OP
74          ((:ARRAY :ARRAY-LEADER :LIST :%P-LDB :FIXNUM)
75           (AND TYPE (ERROR '|The type was given more than once -- DEFSTRUCT| OPTIONS))
76           (SETQ TYPE OP))
77          (:GROUPED-ARRAY
78           (SETQ CONSTRUCTOR-TIMES-OP (COND ((NULL OPARGS) 1)
79                                            (T (CAR OPARGS))))
80           (SETQ GROUPED-P T))
81          (:TIMES
82           (SETQ CONSTRUCTOR-TIMES-OP (FIRST OPARGS)))
83          (:MAKE-ARRAY
84           (SETQ CONSTRUCTOR-ARRAY-OP (FIRST OPARGS)))
85          (:SIZE
86           (SETQ SIZE-SYMBOL (FIRST OPARGS)))
87          (:SIZE-MACRO
88           (SETQ SIZE-MACRO (FIRST OPARGS)))
89          (:CONSTRUCTOR
90           (SETQ CONSTRUCTOR (FIRST OPARGS)))
91          (:INITIAL-OFFSET
92           (SETQ OFFSET (FIRST OPARGS)))
93          (:NAMED
94           (SETQ NAMED-STRUCTURE-P T))
95          (:DEFAULT-POINTER
96           (SETQ DEFAULT-POINTER (FIRST OPARGS)))
97          (:INCLUDE
98           (SETQ INCLUDE (FIRST OPARGS)))
99          (OTHERWISE
100           (ERROR '|Unrecognized option -- DEFSTRUCT| OP))))
101    (OR TYPE (SETQ TYPE 'ARRAY))
102    (COND ((MEMQ TYPE '(%P-LDB FIXNUM))
103           (OR (EQ CONSTRUCTOR T)
104               (ERROR '|DEFSTRUCT type doesn't allow a constructor| TYPE))
105           (SETQ CONSTRUCTOR NIL)
106           (SETQ NOINIT T)))                    ;If can't construct, don't need inits.
107    (AND (EQ CONSTRUCTOR T)
108         (SETQ CONSTRUCTOR (IMPLODE (APPEND '(M A K E -) (EXPLODE NAME)))))
109;Drops through.
110
111;Drops in.
112
113;Done parsing the options, now do some random hacking and error checking.
114    (AND (MEMQ TYPE '(:LIST :%P-LDB :FIXNUM)) NAMED-STRUCTURE-P
115         (ERROR '|This type of structure cannot be a named structure -- DEFSTRUCT| OPTIONS))
116
117    (COND (GROUPED-P
118           (AND NAMED-STRUCTURE-P
119                (ERROR '|A grouped-array cannot be a named-structure -- DEFSTRUCT| OPTIONS))
120           (OR (EQ TYPE ':ARRAY)
121               (ERROR '|A grouped-array must be an array -- DEFSTRUCT| TYPE))))
122
123    (DEFSTRUCT-PUTPROP NAME TYPE 'DEFSTRUCT-TYPE)
124    (AND NAMED-STRUCTURE-P (DEFSTRUCT-PUTPROP NAME T 'DEFSTRUCT-NAMED-P))
125    (AND GROUPED-P (DEFSTRUCT-PUTPROP NAME T 'DEFSTRUCT-GROUPED-P))
126
127    (COND (INCLUDE
128           (OR (NUMBERP (SETQ TEM (GET INCLUDE 'DEFSTRUCT-SIZE)))
129               (ERROR '|The included DEFSTRUCT has not yet been defined -- DEFSTRUCT| INCLUDE))
130           (COND
131            ((AND NAMED-STRUCTURE-P
132                  (NULL (GET INCLUDE 'DEFSTRUCT-NAMED-P)))
133             (ERROR '|A named-structure may not include a non-named-structure -- DEFSTRUCT|
134                    NAME))
135            ((AND (NOT NAMED-STRUCTURE-P)
136                  (GET INCLUDE 'DEFSTRUCT-NAMED-P))
137             (ERROR '|A non-named-structure may not include a named-structure -- DEFSTRUCT|
138                    NAME))
139            ((NEQ (GET INCLUDE 'DEFSTRUCT-TYPE) TYPE)
140             (ERROR '|INCLUDE types did not match -- DEFSTRUCT| TYPE))
141            ((GET INCLUDE 'DEFSTRUCT-GROUPED-P)
142             (ERROR '|A structure may not include a grouped-array -- DEFSTRUCT| NAME))
143            (GROUPED-P
144             (ERROR '|A grouped array may not include another structure -- DEFSTRUCT| NAME)))
145           (SETQ OFFSET (+ OFFSET TEM))))
146
147    ;Now we have OFFSET and can get SIZE.
148    (SETQ SIZE (+ OFFSET (LENGTH ITEMS)))
149    (AND NAMED-STRUCTURE-P (SETQ SIZE (1+ SIZE)))       ;Allocate named-structure-symbol slot
150    (DEFSTRUCT-PUTPROP NAME SIZE 'DEFSTRUCT-SIZE)
151    (AND SIZE-SYMBOL
152         (PUSH `(SETQ ,SIZE-SYMBOL ,SIZE) RETURNS))
153    (AND SIZE-MACRO
154         (PUSH `(MACRO ,SIZE-MACRO (IGNORE) ,SIZE) RETURNS))
155;Drops through.
156
157;Drops in.
158
159;For named-structures, create an additional item for the named-structure-symbol slot
160;The kludge is that this item is called NAMED-STRUCTURE-SYMBOL, but we don't
161;define a macro by that name since there is already a function by that name.
162    (AND NAMED-STRUCTURE-P
163         (NOT INCLUDE)
164         (COND ((EQ TYPE ':ARRAY) (PUSH 'NAMED-STRUCTURE-SYMBOL ITEMS))
165               (T (SETQ ITEMS (CONS (CAR ITEMS)         ;Array-leader element 1
166                                    (CONS 'NAMED-STRUCTURE-SYMBOL
167                                          (CDR ITEMS)))))))
168;Define the accessor macros.  Also, stick the field names onto ITEM-LIST
169;and their initializations (or *NOINIT*)  onto INIT-LIST, in parallel order.
170    (DO ((IL ITEMS (CDR IL))
171         (WHOLE-COMPONENT-INITED NIL NIL)  ;SET THIS IF A "COMPONENT" THAT ACTUALLY REFERS
172                                           ; TO THE WHOLE THING HAS INITIALIZATION.
173                                           ;IF THIS SET, OTHER COMPONENTS THAT REALLY
174                                           ;DO REFER TO JUST COMPONENTS WILL GET NO
175                                           ;INITIALIZATION UNLESS SPECIFICALLY SPECIFIED.
176         (ITEM)
177         ;; OFFSET is the index into the structure of the component about to be defined.
178         (N OFFSET (1+ N)))
179        ((NULL IL)
180         (SETQ ITEM-LIST (REVERSE ITEM-LIST)
181               INIT-LIST (REVERSE INIT-LIST)))
182      (SETQ ITEM (CAR IL))
183
184      (COND ((SYMBOLP ITEM)
185             ;; Handle a word represented by just a symbol - no init specified.
186             (PUSH ITEM ITEM-LIST)
187             (OR NOINIT (PUSH '*NOINIT* INIT-LIST))
188             (OR (EQ ITEM 'NAMED-STRUCTURE-SYMBOL)
189                 (PUSH (DEFSTRUCT-MAKE-ACCESS-MACRO ITEM N NIL DEFAULT-POINTER
190                                                    TYPE GROUPED-P)
191                       RETURNS)))
192            ;; Handle a word which looks like (FOO FOO-INIT)
193            ((SYMBOLP (CAR ITEM))
194             (PUSH (CAR ITEM) ITEM-LIST)
195             (OR NOINIT
196                 (PUSH (COND ((NULL (CDR ITEM)) '*NOINIT*)
197                             (T (CADR ITEM)))
198                       INIT-LIST))
199             (PUSH (DEFSTRUCT-MAKE-ACCESS-MACRO (CAR ITEM) N NIL DEFAULT-POINTER
200                                                TYPE GROUPED-P)
201                   RETURNS))
202            ;; Handle a word which is a list of things like (FOO 1010 FOO-INIT).
203            (T
204             (DO ((L ITEM (CDR L))
205                  (NAME)
206                  (PPSS NIL NIL)
207                  (INIT NIL NIL))
208                 ((NULL L))
209               (SETQ NAME (CAAR L))
210               (COND ((CDAR L)
211                      (SETQ PPSS (CADAR L))
212                      (SETQ INIT (COND ((CDDAR L) (CADDAR L))
213                                       (PPSS (COND (WHOLE-COMPONENT-INITED '*NOINIT*)
214                                                   (T 0)))))
215                      (COND ((AND (NULL PPSS)   ;THIS COMPONENT REALLY REFERS TO WHOLE THING
216                                  (CDDAR L))    ;AND HAS INIT.
217                             (SETQ WHOLE-COMPONENT-INITED T)))))  ;DONT INIT OTHER COMPONENTS
218                                                ;UNLESS THEY SPECIFICALLY HAVE INITS
219               (PUSH NAME ITEM-LIST)
220               (OR NOINIT (PUSH INIT INIT-LIST))
221               (PUSH (DEFSTRUCT-MAKE-ACCESS-MACRO NAME N PPSS DEFAULT-POINTER
222                                                  TYPE GROUPED-P)
223                     RETURNS)
224               ;; If (CAR L) is (FOO 0002 0 (FOO-A FOO-B FOO-C FOO-D)),
225               ;; then we make code to define FOO-A ... FOO-D to be 0 through 3.
226               (AND (CADDDR (CAR L))
227                    (PUSH (DO ((VN (CADDDR (CAR L)) (CDR VN)) (I 0 (1+ I)) (RESULT))
228                              ((NULL VN) (CONS 'SETQ RESULT))
229                             (SETQ RESULT `(,(CAR VN) ,I . ,RESULT)))
230                          RETURNS))))))
231
232    (COND (INCLUDE
233           (SETQ ITEM-LIST (APPEND (GET INCLUDE 'DEFSTRUCT-ITEMS) ITEM-LIST))
234           (OR NOINIT (SETQ INIT-LIST (APPEND (GET INCLUDE 'DEFSTRUCT-INITS) INIT-LIST)))))
235
236    (DEFSTRUCT-PUTPROP NAME ITEM-LIST 'DEFSTRUCT-ITEMS)
237    (OR NOINIT (DEFSTRUCT-PUTPROP NAME INIT-LIST 'DEFSTRUCT-INITS))
238;Drops through.
239
240;Drops in.
241
242;;; Creation of constructor macro.
243
244    (AND CONSTRUCTOR
245         (PUSH `(MACRO ,CONSTRUCTOR (X) ;Create a closure...
246                       (DEFSTRUCT-GRAND-CONSTRUCTOR (CDR X)
247                                                    ',TYPE
248                                                    ',SIZE
249                                                    ',GROUPED-P
250                                                    ',(AND NAMED-STRUCTURE-P NAME)
251                                                    ',ITEM-LIST
252                                                    ',INIT-LIST
253                                                    ',CONSTRUCTOR-ARRAY-OP
254                                                    ',CONSTRUCTOR-TIMES-OP))
255               RETURNS))
256
257    `(PROGN 'COMPILE . ,RETURNS)))
258
259;;; Creation of access macros.
260
261;;; Make an access macro named NAME, which references a
262;;; structure of TYPE type at element INDEX.
263;;; If PPSS is not NIL then it is either a number specifying a byte
264;;; (which the access macro will LDB out) or it is a function or macro
265;;; to call upon the value of the structure's element.
266;;; If DEFAULT-POINTER is not NIL then the generated macro will use
267;;; that object as the operand if no operand is specified.
268;;; If GROUPED-P is T then this should be a "grouped" access macro.
269
270(DEFUN DEFSTRUCT-MAKE-ACCESS-MACRO (NAME INDEX PPSS DEFAULT-POINTER TYPE GROUPED-P)
271  (LET (ARGS BODY)
272    (SETQ ARGS
273          (COND (DEFAULT-POINTER `(&OPTIONAL (Z ,DEFAULT-POINTER)))
274                (T `(Z))))
275    (AND GROUPED-P (SETQ ARGS (CONS 'I ARGS)
276                         INDEX (COND ((ZEROP INDEX) 'I)
277                                     (T `(+ ,INDEX I)))))
278    (SETQ BODY (SELECTQ TYPE
279                   (ARRAY `(AR-1 Z ,INDEX))
280                   (ARRAY-LEADER `(ARRAY-LEADER Z ,INDEX))
281                   (FIXNUM 'Z)
282                   (LIST `(NTH ,INDEX Z))
283                   (%P-LDB
284                      (COND ((NUMBERP PPSS)
285                             `(%P-LDB-OFFSET ,PPSS Z ,INDEX)
286                             (SETQ PPSS NIL))
287                            (T `(%P-CONTENTS-OFFSET Z ,INDEX))))))
288    (COND ((NUMBERP PPSS)
289           (SETQ BODY `(LDB ,PPSS ,BODY)))
290          (PPSS (SETQ BODY `(,PPSS ,BODY))))
291    `(DEFSUBST ,NAME (,@ARGS) ,BODY)))
292
293(DEFUN DEFSTRUCT-GRAND-CONSTRUCTOR (ARGS TYPE SIZE GROUPED-P NAMED-STRUCTURE
294                                         ITEM-LIST INIT-LIST CONSTRUCTOR-ARRAY-OP
295                                         CONSTRUCTOR-TIMES-OP)
296  ;; Process special arguments, and plug in user-specified initializations
297  (LET ((ARGNAME NIL)
298        (MAKER NIL)
299        (GEN (GENSYM))
300        (GEN2 (GENSYM))
301        (WHOLESIZE NIL)
302        (INITED NIL)
303        (MAKE-ARRAY-ARG NIL))
304    (SETQ INIT-LIST (APPEND INIT-LIST NIL))
305    (DO ARGPAIR ARGS (CDDR ARGPAIR) (NULL ARGPAIR)
306      (SETQ ARGNAME (CAR ARGPAIR))
307      (SELECTQ ARGNAME
308         (MAKE-ARRAY (SETQ CONSTRUCTOR-ARRAY-OP (CADR ARGPAIR)))
309         (TIMES (SETQ CONSTRUCTOR-TIMES-OP (CADR ARGPAIR)))
310         (OTHERWISE
311          (DO ((ITEML ITEM-LIST (CDR ITEML))
312               (INITL INIT-LIST (CDR INITL)))
313              ((NULL ITEML)
314               (FERROR NIL "The keyword ~S is not known in a constructor macro." ARGNAME))
315            (COND ((EQ (CAR ITEML) ARGNAME)
316                   (RPLACA INITL (CADR ARGPAIR))
317                   (RETURN NIL)))))))
318
319    (COND ((NEQ TYPE 'LIST)
320           (SETQ WHOLESIZE (COND (GROUPED-P `(* ,SIZE ,CONSTRUCTOR-TIMES-OP))
321                                   (T SIZE))
322                   MAKE-ARRAY-ARG (COND ((EQ TYPE 'ARRAY)
323                                         (LIST 'NIL ''ART-Q (COND (GROUPED-P GEN2)
324                                                                  (T WHOLESIZE))
325                                               'NIL 'NIL 'NIL `',NAMED-STRUCTURE))
326                                        (T (LIST 'NIL ''ART-Q '0 'NIL
327                                                 WHOLESIZE 'NIL `',NAMED-STRUCTURE))))
328
329             ;; Merge the user-specified MAKE-ARRAY option with the facts
330             ;;   that we have figured out.
331             (DO ((MAA MAKE-ARRAY-ARG (CDR MAA))
332                  (CAO CONSTRUCTOR-ARRAY-OP (CDR CAO))
333                  (FOO (COND ((EQ TYPE 'ARRAY)
334                              '(T T NIL T T T NIL))
335                             (T '(T T T T NIL T NIL))) (CDR FOO)))
336                 ((OR (NULL MAA) (NULL CAO)))
337                 (AND (CAR FOO)
338                      (RPLACA MAA (CAR CAO))))
339             (SETQ MAKER `(MAKE-ARRAY . ,MAKE-ARRAY-ARG)))
340          (T (SETQ MAKER `(MAKE-LIST DEFAULT-CONS-AREA ,SIZE))))
341
342    ;; See whether we know the type of the array or list, and if so set up INITED
343    ;; as a function to detect elements being initialized to what they already are.
344    ;; Numeric arrays are already zeros, others are already NILs.
345    (COND ((EQ TYPE 'ARRAY-LEADER)
346           (SETQ INITED (FUNCTION NULL)))
347          ((EQ TYPE 'LIST)
348           (SETQ INITED (FUNCTION NULL)))
349          (T
350            (LET ((FORM (CADR MAKE-ARRAY-ARG)))
351              (COND ((AND (NOT (ATOM FORM))
352                          (EQ (CAR FORM) 'QUOTE))
353                     (SETQ FORM (CADR FORM))))
354              (LET ((X (ASSQ FORM ARRAY-BITS-PER-ELEMENT)))
355                (SETQ INITED
356                      (COND ((NULL X) (FUNCTION FALSE))
357                            ((NULL (CDR X)) (FUNCTION NULL))
358                            (T (FUNCTION ZEROP))))))))
359
360    ;; Generate code to make the structure and to perform the initializations
361    ;; Go over the user-specified initializations and plug them into the initialization list
362    ;; In the list case I would like to plug them directly into the call to LIST,
363    ;; but currently not enough information is generated to do that, so we will
364    ;; generate much less optimal code.  This should be fixed!! ***
365    (DO ((ITEML ITEM-LIST (CDR ITEML))
366         (INITL INIT-LIST (CDR INITL))
367         (GEN1 (GENSYM))
368         (CODE NIL))    ;NOTE: CODE MUST GET BUILT UP IN THE "STRAIGHT" (NOT REVERSED)
369        ((NULL ITEML)   ; ORDER SINCE, WITH COMPONENTS, IT CAN MATTER IN WHICH ORDER
370                        ; THE INITIALIZING IS DONE
371         (COND (GROUPED-P
372                 `(LET ((,GEN2 (* ,SIZE ,CONSTRUCTOR-TIMES-OP)))
373                    (DO ((,GEN1 0 (+ ,GEN1 ,SIZE))
374                         (,GEN ,MAKER))
375                        ((= ,GEN1 ,GEN2)
376                         ,GEN)
377                      . ,CODE)))
378               (T
379                 `(LET ((,GEN ,MAKER))
380                    ,@CODE
381                    ,GEN))))
382      (OR (EQ (CAR INITL) '*NOINIT*)
383          (FUNCALL INITED (CAR INITL))
384          (SETQ CODE (NCONC CODE (LIST `(SETF (,(CAR ITEML)
385                                               ,@(AND GROUPED-P (NCONS GEN1))
386                                               ,GEN)
387                                              ,(CAR INITL)))))))))
388
389;; Property names used herein are:
390;; DEFSTRUCT-TYPE
391;; DEFSTRUCT-NAMED-P
392;; DEFSTRUCT-GROUPED-P
393;; DEFSTRUCT-SIZE
394;; DEFSTRUCT-ITEMS
395;; DEFSTRUCT-INITS
396
397
398;(SETF (element pntr) value)
399
400(DEFUN SETF MACRO (X) (SETF-1 X))
401
402(DEFUN SETF-1 (X)
403    (OR (= (LENGTH X) 3)
404        (ERROR "SETF called with wrong number of arguments" X))
405    (DO ((REF (CADR X)) (VAL (CADDR X)) (FCN)) (NIL)
406       (COND ((SYMBOLP REF)                             ;SPECIAL CASE NEEDED.
407              (RETURN (LIST 'SETQ REF VAL)))
408             ((SETQ FCN (GET (CAR REF) 'SETF))
409              (RETURN (LOCF-APPLY FCN REF T VAL)))
410             ((SETQ FCN (GET (CAR REF) 'SETF-EXPANDER))
411              (SETQ REF (LOCF-APPLY FCN REF NIL NIL)))
412             ((NOT (EQ REF (SETQ REF (MACROEXPAND-1 REF T)))))
413             (T (ERROR "No SETF property found, can't invert this reference" X)))))
414
415;(LOCF (element pntr))
416;Constructs a form which returns a locative pointer to the "referenced" element
417;of the structure.
418(DEFUN LOCF MACRO (X) (LOCF-1 X))
419
420(DEFUN LOCF-1 (X)
421    (OR (= (LENGTH X) 2)
422        (ERROR "LOCF called with wrong number of arguments" X))
423    (DO ((REF (CADR X)) (FCN)) (NIL)
424       (COND ((SYMBOLP REF)                     ;SPECIAL CASE NEEDED.
425              (RETURN `(VALUE-CELL-LOCATION ',REF)))
426             ((SETQ FCN (GET (CAR REF) 'LOCF))
427              (RETURN (LOCF-APPLY FCN REF NIL NIL)))
428             ((SETQ FCN (GET (CAR REF) 'SETF-EXPANDER))
429              (SETQ REF (LOCF-APPLY FCN REF NIL NIL)))
430             ((NOT (EQ REF (SETQ REF (MACROEXPAND-1 REF T)))))
431             (T (ERROR "No LOCF property found, can't work." X)))))
432
433(DEFUN LOCF-APPLY (FCN REF VAL-P VAL)
434    (COND ((ATOM FCN)
435           (COND (VAL-P (FUNCALL FCN REF VAL))
436                 (T (FUNCALL FCN REF))))
437          (T (DO ((PATTERN (CDAR FCN) (CDR PATTERN))
438                  (REF (CDR REF) (CDR REF))
439                  (SUBS
440                     (AND VAL-P (LIST (CONS 'VAL VAL)))
441                     (CONS (CONS (CAR PATTERN) (CAR REF)) SUBS)))
442                 ((OR (NULL PATTERN) (NULL REF))
443                  (AND (OR PATTERN REF)
444                       (ERROR "Reference not same length as pattern - LOCF or SETF" REF))
445                  (SUBLIS SUBS (CDR FCN)))))))
446
447;(GET-LIST-POINTER-INTO-STRUCT (element pntr))
448
449(DEFUN GET-LIST-POINTER-INTO-STRUCT MACRO (X)
450  (PROG (REF)
451    (SETQ REF (MACROEXPAND (CADR X) T)) ;EXPAND MACROS LOOKING AT BAG-BITING MACRO LIST
452    (COND ((EQ (CAR REF) 'AR-1)
453           (RETURN (LIST 'GET-LIST-POINTER-INTO-ARRAY
454                         (LIST 'FUNCALL (CADR REF) (CADDR REF)))))
455          ((ERROR "LOSES - GET-LIST-POINTER-INTO-STRUCT" X)))))
456
457;Load time defprops for SETF and LOCF.
458;Value of the SETF property is either an symbol which is a function
459; which is applied to two arguments: the reference and the value
460; to be stored into it, or it is CONS of a 1-level pattern to
461; match against REF and a form in which substitutions
462; are made for the symbol VAL and the pattern atoms.
463;The value of the LOCF property is very similar; if it is
464;a symbol then it is a function to be applied to one argument,
465;the reference.  Otherwise it is a pattern as in SETF, except
466;that the symbol VAL is not special.
467
468;A SETF-EXPANDER property looks like a LOCF property,
469;but instead of telling how to get the location of the value
470;it gives another expression for the same value.
471;The idea is that that expression will be amenable to SETF/LOCF.
472
473;;; (DEFPROP AREF ((AREF ARRAY . SUBSCRIPTS)
474;;;                 ASET VAL ARRAY . SUBSCRIPTS) SETF)
475;;; (DEFPROP AREF ((AREF ARRAY . SUBSCRIPTS)
476;;;                 ALOC ARRAY . SUBSCRIPTS) LOCF)
477
478(DEFPROP AREF AREF-SETF SETF)
479(DEFUN AREF-SETF (REF VAL)
480    `(ASET ,VAL . ,(CDR REF)))
481(DEFPROP AREF AREF-LOCF LOCF)
482(DEFUN AREF-LOCF (REF)
483    `(ALOC . ,(CDR REF)))
484
485(DEFPROP AR-1 ((AR-1 ARRAY INDEX)
486               AS-1 VAL ARRAY INDEX) SETF)
487(DEFPROP AR-1 ((AR-1 ARRAY INDEX)
488               AP-1 ARRAY INDEX) LOCF)
489
490(DEFPROP AR-2 ((AR-2 ARRAY INDEX1 INDEX2)
491               AS-2 VAL ARRAY INDEX1 INDEX2) SETF)
492(DEFPROP AR-2 ((AR-2 ARRAY INDEX1 INDEX2)
493               AP-2 ARRAY INDEX1 INDEX2) LOCF)
494
495(DEFPROP AR-3 ((AR-3 ARRAY INDEX1 INDEX2 INDEX3)
496               AS-3 VAL ARRAY INDEX1 INDEX2 INDEX3) SETF)
497(DEFPROP AR-3 ((AR-3 ARRAY INDEX1 INDEX2 INDEX3)
498               AP-3 ARRAY INDEX1 INDEX2 INDEX3) LOCF)
499
500(DEFPROP ARRAY-LEADER ((ARRAY-LEADER ARRAY INDEX)
501                       STORE-ARRAY-LEADER VAL ARRAY INDEX) SETF)
502(DEFPROP ARRAY-LEADER ((ARRAY-LEADER ARRAY INDEX)
503                       AP-LEADER ARRAY INDEX) LOCF)
504
505(DEFPROP CDR ((CDR ITEM) . (RPLACD ITEM VAL)) SETF)
506(DEFPROP CDR ((CDR LIST) . LIST) LOCF)
507
508(DEFPROP CAR ((CAR LIST) . (RPLACA LIST VAL)) SETF)
509(DEFPROP CAR ((CAR LIST) . (CAR-LOCATION LIST)) LOCF)
510
511(DEFPROP CDDR ((CDDR ITEM) . (CDR (CDR ITEM))) SETF-EXPANDER)
512(DEFPROP CDDDR ((CDDDR ITEM) . (CDR (CDDR ITEM))) SETF-EXPANDER)
513(DEFPROP CDDDDR ((CDDDDR ITEM) . (CDR (CDDDR ITEM))) SETF-EXPANDER)
514(DEFPROP CDDDAR ((CDDDAR ITEM) . (CDR (CDDAR ITEM))) SETF-EXPANDER)
515(DEFPROP CDDAR ((CDDAR ITEM) . (CDR (CDAR ITEM))) SETF-EXPANDER)
516(DEFPROP CDDADR ((CDDADR ITEM) . (CDR (CDADR ITEM))) SETF-EXPANDER)
517(DEFPROP CDDAAR ((CDDAAR ITEM) . (CDR (CDAAR ITEM))) SETF-EXPANDER)
518(DEFPROP CDAR ((CDAR ITEM) . (CDR (CAR ITEM))) SETF-EXPANDER)
519(DEFPROP CDADR ((CDADR ITEM) . (CDR (CADR ITEM))) SETF-EXPANDER)
520(DEFPROP CDADDR ((CDADDR ITEM) . (CDR (CADDR ITEM))) SETF-EXPANDER)
521(DEFPROP CDADAR ((CDADAR ITEM) . (CDR (CADAR ITEM))) SETF-EXPANDER)
522(DEFPROP CDAADR ((CDAADR ITEM) . (CDR (CAADR ITEM))) SETF-EXPANDER)
523(DEFPROP CDAAAR ((CDAAAR ITEM) . (CDR (CAAAR ITEM))) SETF-EXPANDER)
524(DEFPROP CADR ((CADR ITEM) . (CAR (CDR ITEM))) SETF-EXPANDER)
525(DEFPROP CADDR ((CADDR ITEM) . (CAR (CDDR ITEM))) SETF-EXPANDER)
526(DEFPROP CADDDR ((CADDDR ITEM) . (CAR (CDDDR ITEM))) SETF-EXPANDER)
527(DEFPROP CADDAR ((CADDAR ITEM) . (CAR (CDDAR ITEM))) SETF-EXPANDER)
528(DEFPROP CADAR ((CADAR ITEM) . (CAR (CDAR ITEM))) SETF-EXPANDER)
529(DEFPROP CADADR ((CADADR ITEM) . (CAR (CDADR ITEM))) SETF-EXPANDER)
530(DEFPROP CADAAR ((CADAAR ITEM) . (CAR (CDAAR ITEM))) SETF-EXPANDER)
531(DEFPROP CAAR ((CAAR ITEM) . (CAR (CAR ITEM))) SETF-EXPANDER)
532(DEFPROP CAADR ((CAADR ITEM) . (CAR (CADR ITEM))) SETF-EXPANDER)
533(DEFPROP CAADDR ((CAADDR ITEM) . (CAR (CADDR ITEM))) SETF-EXPANDER)
534(DEFPROP CAADAR ((CAADAR ITEM) . (CAR (CADAR ITEM))) SETF-EXPANDER)
535(DEFPROP CAAADR ((CAAADR ITEM) . (CAR (CAADR ITEM))) SETF-EXPANDER)
536(DEFPROP CAAAAR ((CAAAAR ITEM) . (CAR (CAAAR ITEM))) SETF-EXPANDER)
537(DEFPROP NTH ((NTH N LIST) . (CAR (NTHCDR N LIST))) SETF-EXPANDER)
538
539(DEFPROP FSYMEVAL ((FSYMEVAL SYMBOL) . (FSET SYMBOL VAL)) SETF)
540(DEFPROP FSYMEVAL ((FSYMEVAL SYMBOL) . (FUNCTION-CELL-LOCATION SYMBOL)) LOCF)
541
542(DEFPROP SYMEVAL ((SYMEVAL SYMBOL) . (SET SYMBOL VAL)) SETF)
543(DEFPROP SYMEVAL ((SYMEVAL SYMBOL) . (VALUE-CELL-LOCATION SYMBOL)) LOCF)
544
545(DEFPROP SYMEVAL-IN-CLOSURE ((SYMEVAL-IN-CLOSURE CLOSURE PTR)
546                             SET-IN-CLOSURE CLOSURE PTR VAL) SETF)
547(DEFPROP SYMEVAL-IN-CLOSURE ((SYMEVAL-IN-CLOSURE CLOSURE PTR)
548                             LOCATE-IN-CLOSURE CLOSURE PTR) LOCF)
549
550;;; This really should be called SEND or something like that
551(DEFPROP FUNCALL FUNCALL-SETF SETF)
552(DEFUN FUNCALL-SETF (REF VAL)
553  (OR (AND (= (LENGTH REF) 3)
554           (NOT (ATOM (CADDR REF))) (EQ (CAADDR REF) 'QUOTE))
555      (ERROR "Can only setf message sending funcalls" REF))
556  `(FUNCALL ,(CADR REF) ',(INTERN (STRING-APPEND "SET-" (CADR (CADDR REF))) "") ,VAL))
557
558(defprop function function-setf setf)
559(defun function-setf (ref val)
560       (or (symbolp (cadr ref))
561           (error "Cannot setf this." ref))
562       `(fset ',(cadr ref) ,val))
563
564(defprop function function-locf locf)
565(defun function-locf (ref)
566       (or (symbolp (cadr ref))
567           (error "Cannot locf this." ref))
568       `(function-cell-location ',(cadr ref)))
569
570(defprop plist ((plist foo) . (setplist foo val)) setf)
571(defprop plist ((plist foo) . (property-cell-location foo)) locf)
572
573;The old thing.  Also evals ref twice, lose lose.
574(DEFPROP LDB ((LDB PPSS REF) . (SETF REF (DPB VAL PPSS REF))) SETF)
575;The following tried to fix a hairy bug associated with (setf (ldb (cdr x)) 105).
576; Unfortunately, it suffers from a worse problem, namely, the ref can be a
577; array element of a numeric array, in which case it is illegal (and impossible)
578; to make a locative pointer.
579;(DEFPROP LDB ((LDB PPSS REF) . (DPB-VIA-LOCATIVE VAL PPSS (LOCF REF))) SETF)
580;(IF-FOR-LISPM
581;(DEFUN DPB-VIA-LOCATIVE (VAL PPSS LOCATIVE)  ;THIS MUST BE IN QRAND BECAUSE IT MUST BE
582;    (RPLACD LOCATIVE (DPB VAL PPSS (CDR LOCATIVE)))))  ;IN THE COLD LOAD
583
584(DEFPROP GET ((GET ATOM PROP) . (PUTPROP ATOM VAL PROP)) SETF)
585(DEFPROP GET ((GET ATOM PROP) . (GET-LOCATION ATOM PROP)) LOCF)
586
587(DEFPROP ARG ((ARG N) . (SETARG N VAL)) SETF)
588
589(DEFPROP %UNIBUS-READ ((%UNIBUS-READ ADDR) . (%UNIBUS-WRITE ADDR VAL)) SETF)
590(DEFPROP %XBUS-READ ((%XBUS-READ ADDR) . (%XBUS-WRITE ADDR VAL)) SETF)
591
592(DEFPROP %P-CONTENTS-OFFSET ((%P-CONTENTS-OFFSET BASE OFFSET)
593                             %P-STORE-CONTENTS-OFFSET VAL BASE OFFSET) SETF)
594(DEFPROP %P-CONTENTS-OFFSET ((%P-CONTENTS-OFFSET POINTER OFFSET)
595                             %MAKE-POINTER-OFFSET DTP-LOCATIVE POINTER OFFSET) LOCF)
596
597(DEFPROP %P-LDB ((%P-LDB PPSS POINTER)
598                 %P-DPB VAL PPSS POINTER) SETF)
599
600(DEFPROP %P-LDB-OFFSET ((%P-LDB-OFFSET PPSS POINTER OFFSET)
601                        %P-DPB-OFFSET VAL PPSS POINTER OFFSET) SETF)
602
603(DEFPROP %P-MASK-FIELD ((%P-MASK-FIELD PPSS POINTER)
604                        %P-DEPOSIT-FIELD VAL PPSS POINTER) SETF)
605
606(DEFPROP %P-MASK-FIELD-OFFSET ((%P-MASK-FIELD-OFFSET PPSS POINTER OFFSET)
607                               %P-DEPOSIT-FIELD-OFFSET VAL PPSS POINTER OFFSET) SETF)
608
609(DEFPROP %P-POINTER ((%P-POINTER POINTER)
610                     %P-STORE-POINTER POINTER VAL) SETF)
611
612(DEFPROP %P-DATA-TYPE ((%P-DATA-TYPE POINTER)
613                       %P-STORE-DATA-TYPE POINTER VAL) SETF)
614
615(DEFPROP %P-CDR-CODE ((%P-CDR-CODE POINTER)
616                      %P-STORE-CDR-CODE POINTER VAL) SETF)
617
618(DEFPROP %P-FLAG-BIT ((%P-FLAG-BIT POINTER)
619                      %P-STORE-FLAG-BIT POINTER VAL) SETF)
620
621;Handle SETF of backquote expressions, for decomposition.
622;For example, (SETF `(A ,B (D ,XYZ)) FOO)
623;sets B to the CADR and XYZ to the CADADDR of FOO.
624;The constants in the pattern are ignored.
625
626;Backquotes which use ,@ or ,. other than at the end of a list
627;expand into APPENDs or NCONCs and cannot be SETF'd.
628
629(COMMENT
630;This was used for making (setf `(a ,b) foo) return t if
631;foo matched the pattern (had A as its car).
632;The other change for reinstalling this
633;would be to replace the PROGNs with ANDs
634;in the expansions produced by (LIST SETF), etc.
635(DEFUN SETF-MATCH (PATTERN OBJECT)
636  (COND ((NULL PATTERN) T)
637        ((SYMBOLP PATTERN)
638         `(PROGN (SETQ ,PATTERN ,OBJECT) T))
639        ((EQ (CAR PATTERN) 'QUOTE)
640         `(EQUAL ,PATTERN ,OBJECT))
641        ((MEMQ (CAR PATTERN)
642               '(CONS LIST LIST*))
643         `(SETF ,PATTERN ,OBJECT))
644        (T `(PROGN (SETF ,PATTERN ,OBJECT) T)))))
645
646;This is used for ignoring any constants in the
647;decomposition pattern, so that (setf `(a ,b) foo)
648;always sets b and ignores a.
649(DEFUN SETF-MATCH (PATTERN OBJECT)
650  (COND ((AND (NOT (ATOM PATTERN)) (EQ (CAR PATTERN) 'QUOTE))
651         NIL)
652        (T `(SETF ,PATTERN ,OBJECT))))
653
654(DEFUN (LIST SETF) (PATTERN VALUE-FORM &AUX VARIABLE)
655  (COND ((SYMBOLP VALUE-FORM)
656         (SETQ VARIABLE VALUE-FORM
657               VALUE-FORM NIL))
658        (T (SETQ VARIABLE (GENSYM))))
659  (DO ((I 0 (1+ I))
660       (ACCUM)
661       (ARGS (CDR PATTERN) (CDR ARGS)))
662      ((NULL ARGS)
663       (COND (VALUE-FORM
664               `(LET ((,VARIABLE ,VALUE-FORM))
665                  (PROGN . ,(NREVERSE ACCUM))))
666             (T (CONS 'PROGN (NREVERSE ACCUM)))))
667    (PUSH (SETF-MATCH (CAR ARGS) `(NTH ,I ,VARIABLE)) ACCUM)))
668
669(DEFUN (LIST* SETF) (PATTERN VALUE-FORM &AUX VARIABLE)
670  (COND ((SYMBOLP VALUE-FORM)
671         (SETQ VARIABLE VALUE-FORM
672               VALUE-FORM NIL))
673        (T (SETQ VARIABLE (GENSYM))))
674  (DO ((I 0 (1+ I))
675       (ACCUM)
676       (ARGS (CDR PATTERN) (CDR ARGS)))
677      ((NULL ARGS)
678       (COND (VALUE-FORM
679               `(LET ((,VARIABLE ,VALUE-FORM))
680                  (PROGN . ,(NREVERSE ACCUM))))
681             (T (CONS 'PROGN (NREVERSE ACCUM)))))
682    (COND ((CDR ARGS)
683           (PUSH (SETF-MATCH (CAR ARGS) `(NTH ,I ,VARIABLE)) ACCUM))
684          (T (PUSH (SETF-MATCH (CAR ARGS) `(NTHCDR ,I ,VARIABLE)) ACCUM)))))
685
686(DEFUN (CONS SETF) (PATTERN VALUE-FORM &AUX VARIABLE)
687  (COND ((SYMBOLP VALUE-FORM)
688         (SETQ VARIABLE VALUE-FORM
689               VALUE-FORM NIL))
690        (T (SETQ VARIABLE (GENSYM))))
691  (LET ((TEM `(PROGN ,(SETF-MATCH (CADR PATTERN) `(CAR ,VARIABLE))
692                     ,(SETF-MATCH (CADDR PATTERN) `(CDR ,VARIABLE)))))
693    (COND (VALUE-FORM
694            `(LET ((,VARIABLE ,VALUE-FORM))
695               ,TEM))
696          (T TEM))))
Note: See TracBrowser for help on using the repository browser.