Skip to content

Commit 6c86838

Browse files
rmkaplanrmkaplan
committed
Macros for multi-level alists
1 parent d909001 commit 6c86838

File tree

3 files changed

+239
-0
lines changed

3 files changed

+239
-0
lines changed

‎lispusers/MULTI-ALIST‎

Lines changed: 239 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,239 @@
1+
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
2+
3+
(FILECREATED "29-Jan-2025 19:34:13" {WMEDLEY}<lispusers>MULTI-ALIST.;15 12223
4+
5+
:EDIT-BY rmk
6+
7+
:CHANGES-TO (FNS MAPMULTI)
8+
9+
:PREVIOUS-DATE "25-Jan-2025 15:04:13" {WMEDLEY}<lispusers>MULTI-ALIST.;14)
10+
11+
12+
(PRETTYCOMPRINT MULTI-ALISTCOMS)
13+
14+
(RPAQQ MULTI-ALISTCOMS
15+
((MACROS GETMULTI PUTMULTI PUTMULTI-D PUTMULTI-NEW PUTMULTI-COUNT PUTMULTI-SUM REMOVEMULTI
16+
REMOVEMULTIALL)
17+
(MACROS FGETMULTI FPUTMULTI FPUTMULTI-D FPUTMULTI-NEW)
18+
(FNS MAPMULTI MAPMULTI1 COLLECTMULTI)
19+
(FNS GETMULTI.EXPAND PUTMULTI.EXPAND REMOVEMULTI.EXPAND)
20+
(MACROS ADDTOMULTI)
21+
(FNS ADDTOMULTI1)
22+
(LOCALVARS . T)))
23+
(DECLARE%: EVAL@COMPILE
24+
25+
(PUTPROPS GETMULTI MACRO (ARGS (GETMULTI.EXPAND 'SASSOC ARGS)))
26+
27+
(PUTPROPS PUTMULTI MACRO (ARGS (PUTMULTI.EXPAND 'SASSOC ARGS)))
28+
29+
(PUTPROPS PUTMULTI-D MACRO (ARGS (PUTMULTI.EXPAND 'SASSOC ARGS NIL T)))
30+
31+
(PUTPROPS PUTMULTI-NEW MACRO (ARGS (PUTMULTI.EXPAND 'SASSOC ARGS)))
32+
33+
(PUTPROPS PUTMULTI-COUNT MACRO (ARGS (PUTMULTI.EXPAND 'SASSOC (APPEND ARGS '(1))
34+
NIL NIL T)))
35+
36+
(PUTPROPS PUTMULTI-SUM MACRO (ARGS (PUTMULTI.EXPAND 'SASSOC ARGS NIL NIL T)))
37+
38+
(PUTPROPS REMOVEMULTI MACRO (ARGS (REMOVEMULTI.EXPAND ARGS)))
39+
40+
(PUTPROPS REMOVEMULTIALL MACRO (ARGS (REMOVEMULTI.EXPAND ARGS T)))
41+
)
42+
(DECLARE%: EVAL@COMPILE
43+
44+
(PUTPROPS FGETMULTI MACRO (ARGS (GETMULTI.EXPAND 'FASSOC ARGS)))
45+
46+
(PUTPROPS FPUTMULTI MACRO (ARGS (PUTMULTI.EXPAND 'FASSOC ARGS)))
47+
48+
(PUTPROPS FPUTMULTI-D MACRO (ARGS (PUTMULTI.EXPAND 'FASSOC ARGS NIL T)))
49+
50+
(PUTPROPS FPUTMULTI-NEW MACRO (ARGS (PUTMULTI.EXPAND 'FASSOC ARGS)))
51+
)
52+
(DEFINEQ
53+
54+
(MAPMULTI
55+
[LAMBDA (MULTIALIST MAPFN) (* ; "Edited 29-Jan-2025 19:33 by rmk")
56+
(* ; "Edited 25-Jan-2025 14:51 by rmk")
57+
(* ; "Edited 16-Jan-2025 10:32 by rmk")
58+
(* ; "Edited 6-Jan-2020 10:15 by rmk:")
59+
60+
(* ;; "MAPMULTI applies a mapping function of N args to each item in an N-way item in the multi-alist at MULTIALIST. If an item C is inserted by (PUTMULTI FOO A B C), then MAPFN should be a 3 argument function and it will be applied to A B C. The caller is responsible for making sure the arities of the index and the mapfn correspond.")
61+
62+
(DECLARE (SPECVARS MAPFN))
63+
(LET ($$LISTFORARGS$$)
64+
(DECLARE (SPECVARS $$LISTFORARGS$$))
65+
(SETQ $$LISTFORARGS$$ (FOR I FROM 1 TO (NARGS MAPFN) COLLECT NIL))
66+
(MAPMULTI1 MULTIALIST $$LISTFORARGS$$ (NARGS MAPFN])
67+
68+
(MAPMULTI1
69+
[LAMBDA (SUBALIST ARGLIST NREMAINING) (* ; "Edited 25-Jan-2025 15:03 by rmk")
70+
(* ; "Edited 22-Jan-2025 23:42 by rmk")
71+
(* ; "Edited 16-Jan-2025 10:29 by rmk")
72+
(* ; "Edited 6-Jan-2020 10:21 by rmk:")
73+
(DECLARE (USEDFREE $$LISTFORARGS$$ MAPFN))
74+
(if [AND (IGREATERP NREMAINING 1)
75+
(LISTP (CAR (LISTP SUBALIST]
76+
then
77+
(* ;; "Still a list of alists.")
78+
79+
(for SI in SUBALIST do (RPLACA ARGLIST (CAR SI))
80+
(MAPMULTI1 (CDR SI)
81+
(CDR ARGLIST)
82+
(SUB1 NREMAINING)))
83+
else (for ITEM inside SUBALIST do (RPLACA ARGLIST ITEM)
84+
(APPLY MAPFN $$LISTFORARGS$$])
85+
86+
(COLLECTMULTI
87+
[LAMBDA (MULTIALIST MAPFN) (* ; "Edited 25-Jan-2025 15:00 by rmk")
88+
(* ; "Edited 22-Jan-2025 23:44 by rmk")
89+
(* ; "Edited 6-Jan-2020 10:15 by rmk:")
90+
(LET ($$COLLECT)
91+
(DECLARE (SPECVARS $$COLLECT))
92+
(MAPMULTI MULTIALIST MAPFN)
93+
$$COLLECT])
94+
)
95+
(DEFINEQ
96+
97+
(GETMULTI.EXPAND
98+
[LAMBDA (ASSOCFN ARGS) (* ; "Edited 16-Jan-2025 10:27 by rmk")
99+
(* ; "Edited 19-Jul-2020 00:38 by rmk:")
100+
(* ; "Edited 22-Mar-2020 13:21 by rmk:")
101+
(* ; "Edited 27-Feb-2020 13:44 by rmk:")
102+
(* ; "Edited 30-Dec-2019 20:50 by rmk:")
103+
104+
(* ;; "If SUM, returns the value after the last argument, paired with PUTMULTISUM")
105+
106+
(IF (CDR ARGS)
107+
THEN `(LET ($$CELL$$)
108+
(DECLARE (LOCALVARS $$CELL$$))
109+
,@[FOR ATAIL (HEAD _ (CAR ARGS)) ON (CDR ARGS)
110+
COLLECT (PROG1 `[SETQ $$CELL$$ (CDR (,ASSOCFN ,(CAR ATAIL)
111+
,HEAD]
112+
(SETQ HEAD '$$CELL$$))]
113+
$$CELL$$)
114+
ELSE (CAR ARGS])
115+
116+
(PUTMULTI.EXPAND
117+
[LAMBDA (ASSOCFN ARGS ALLOWREPEATS SINGLEVALUE SUM) (* ; "Edited 23-Jan-2025 09:40 by rmk")
118+
(* ; "Edited 16-Jan-2025 10:18 by rmk")
119+
(* ; "Edited 17-Aug-2020 14:09 by rmk:")
120+
121+
(* ;; "If ALLOWREPEATS, doesn't test (MEMBER) for preexisting values, just accumulates")
122+
123+
(* ;; "If SINGLEVALUE, new value smashes out old")
124+
125+
(* ;; "For SUM, the last argument is the increment to be added to the current value, and the incremented value is returned for PUTMULTISUM and for GETMULT")
126+
127+
(* ;; "")
128+
129+
(* ;; "We get the setf method so that any expressions in the form will be evaluated only once.")
130+
131+
(CL:MULTIPLE-VALUE-BIND
132+
(TEMPVARS VALFORMS STOREVARS STOREFORM ACCESSFORM)
133+
(CL:GET-SETF-METHOD (CAR ARGS))
134+
(CL:IF (CDR ARGS)
135+
`(LET*
136+
,(FOR VF IN VALFORMS AS TV IN TEMPVARS COLLECT (LIST TV VF))
137+
(DECLARE (LOCALVARS ,@TEMPVARS))
138+
(LET
139+
($$ARG1$$ $$ARG2$$)
140+
(DECLARE (LOCALVARS $$ARG1$$ $$ARG2$$))
141+
,@[FOR ATAIL (HEAD _ ACCESSFORM) ON ARGS WHILE (CDR ATAIL)
142+
JOIN
143+
(IF (AND SUM (NULL (CDDR ATAIL)))
144+
THEN (POP ATAIL)
145+
`[(CL:UNLESS ,HEAD (RPLACD $$ARG1$$ 0))
146+
(SETQ $$ARG2$$ (ADD ,HEAD ,(CAR ATAIL]
147+
ELSE
148+
(PROG1 `[(SETQ $$ARG2$$ ,(CADR ATAIL))
149+
,(IF (CDDR ATAIL)
150+
THEN `[SETQ $$ARG1$$ (OR (,ASSOCFN $$ARG2$$ ,HEAD)
151+
(CAR (CL:PUSH (CONS $$ARG2$$)
152+
,HEAD]
153+
ELSEIF ALLOWREPEATS
154+
THEN `(push ,HEAD $$ARG2$$)
155+
ELSEIF SINGLEVALUE
156+
THEN `(RPLACD $$ARG2$$)
157+
ELSE `(OR (MEMBER $$ARG2$$ ,HEAD)
158+
(push ,HEAD $$ARG2$$]
159+
(SETQ HEAD '(CDR $$ARG1$$)))]
160+
$$ARG2$$))
161+
(CAR ARGS))])
162+
163+
(REMOVEMULTI.EXPAND
164+
[LAMBDA (ARGS ALLFLAG) (* ; "Edited 16-Jan-2025 10:34 by rmk")
165+
(* ; "Edited 17-Aug-2020 15:12 by rmk:")
166+
(* ; "Edited 17-May-2020 17:25 by rmk:")
167+
(* ; "Edited 14-Feb-2020 11:24 by rmk:")
168+
(* ; "Edited 25-Dec-2019 09:57 by rmk:")
169+
170+
(* ;; "If ALLFLAG, then all data after the last of ARGS, if any, is removed. That is, if there are 3 keys to the index, and REMOVEMULTIALL is invoked with 2 keys, then it's as if no entries were made for any of the third keys after those first two. In the case of REMOVEMULTIALL, it returns the previous tail.")
171+
172+
(* ;; "No point in distinguishing FASSOC from SASSOC here.")
173+
174+
(CL:MULTIPLE-VALUE-BIND
175+
(TEMPVARS VALFORMS STOREVARS STOREFORM ACCESSFORM)
176+
(CL:GET-SETF-METHOD (CAR ARGS))
177+
(CL:IF (CDR ARGS)
178+
`(LET*
179+
,(FOR VF IN VALFORMS AS TV IN TEMPVARS COLLECT (LIST TV VF))
180+
(DECLARE (LOCALVARS ,@TEMPVARS))
181+
(LET
182+
($$ARG1$$ $$ARG2$$)
183+
(DECLARE (LOCALVARS $$ARG1$$ $$ARG2$$))
184+
,@[FOR ATAIL (HEAD _ ACCESSFORM) ON ARGS WHILE (CDR ATAIL)
185+
JOIN (PROG1 `[(SETQ $$ARG2$$ ,(CADR ATAIL))
186+
,(IF (CDDR ATAIL)
187+
THEN `(SETQ $$ARG1$$ (SASSOC $$ARG2$$ ,HEAD))
188+
ELSEIF ALLFLAG
189+
THEN `(CL:WHEN (SETQ $$ARG1$$ (SASSOC $$ARG2$$ ,HEAD))
190+
(SETQ $$ARG2$$ (CDR $$ARG1$$))
191+
(RPLACD $$ARG1$$))
192+
ELSE `(AND (SETQ $$ARG2$$ (MEMBER $$ARG2$$ ,HEAD))
193+
(RPLACD $$ARG1$$ (DREMOVE (SETQ $$ARG2$$ (CAR $$ARG2$$))
194+
,HEAD]
195+
(SETQ HEAD '(CDR $$ARG1$$)))]
196+
$$ARG2$$))
197+
(CAR ARGS))])
198+
)
199+
(DECLARE%: EVAL@COMPILE
200+
201+
(PUTPROPS ADDTOMULTI MACRO [ARGS (CL:MULTIPLE-VALUE-BIND
202+
(TEMPVARS VALFORMS STOREVARS STOREFORM ACCESSFORM)
203+
(CL:GET-SETF-METHOD (CAR ARGS))
204+
`(LET* [,@(FOR VF IN VALFORMS AS TV IN TEMPVARS
205+
COLLECT (LIST TV VF))
206+
($$KEYS ,(CADR ARGS]
207+
(DECLARE (LOCALVARS $$KEYS ,@TEMPVARS))
208+
(COND
209+
[(LISTP $$KEYS)
210+
(CL:UNLESS (SASSOC (CAR $$KEYS)
211+
,ACCESSFORM)
212+
(CL:PUSH (CONS (CAR $$KEYS))
213+
,ACCESSFORM))
214+
(ADDTOMULTI1 ,ACCESSFORM $$KEYS ,(CADDR ARGS]
215+
(T (CL:SETF ,ACCESSFORM ,(CADDR ARGS])
216+
)
217+
(DEFINEQ
218+
219+
(ADDTOMULTI1
220+
[LAMBDA (PLACE KEYS VAL) (* ; "Edited 22-Jan-2025 23:47 by rmk")
221+
(* ; "Edited 17-Aug-2020 15:05 by rmk:")
222+
223+
(* ;; "This allows the keys to be provided in a single list rather than as separate arguments.")
224+
225+
(FOR I (P _ PLACE) IN KEYS DO [SETQ P (OR (SASSOC I P)
226+
(CAR (PUSH (CDR P)
227+
(CONS I] FINALLY (PUSH (CDR P)
228+
VAL))
229+
VAL])
230+
)
231+
(DECLARE%: DOEVAL@COMPILE DONTCOPY
232+
233+
(LOCALVARS . T)
234+
)
235+
(DECLARE%: DONTCOPY
236+
(FILEMAP (NIL (1837 4449 (MAPMULTI 1847 . 2915) (MAPMULTI1 2917 . 3974) (COLLECTMULTI 3976 . 4447)) (
237+
4450 10311 (GETMULTI.EXPAND 4460 . 5581) (PUTMULTI.EXPAND 5583 . 7995) (REMOVEMULTI.EXPAND 7997 .
238+
10309)) (11461 12146 (ADDTOMULTI1 11471 . 12144)))))
239+
STOP

‎lispusers/MULTI-ALIST.LCOM‎

4.9 KB
Binary file not shown.

‎lispusers/MULTI-ALIST.TEDIT‎

10.2 KB
Binary file not shown.

0 commit comments

Comments
 (0)