Skip to content

GETMULTI in MULTI-ALIST is a Place #2245

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Closed
wants to merge 1 commit into from
Closed

GETMULTI in MULTI-ALIST is a Place #2245

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
218 changes: 218 additions & 0 deletions library/MULTI-ALIST
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,218 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)

(FILECREATED " 8-Aug-2025 12:59:32" 
{DSK}<Users>kaplan>Local>medley3.5>working-medley>library>MULTI-ALIST.;2 11013

:EDIT-BY rmk

:CHANGES-TO (VARS MULTI-ALISTCOMS)
(MACROS GETMULTI FGETMULTI GETMULTI-PAIR REMOVEMULTI REMOVEMULTIALL FGETMULTI-PAIR)
(FNS GETMULTI.EXPAND)

:PREVIOUS-DATE "10-Jul-2025 12:37:33"
{DSK}<Users>kaplan>Local>medley3.5>working-medley>library>MULTI-ALIST.;1)


(PRETTYCOMPRINT MULTI-ALISTCOMS)

(RPAQQ MULTI-ALISTCOMS
((MACROS GETMULTI GETMULTI-PAIR PUSHMULTI PUTMULTI PUSHMULTI-NEW REMOVEMULTI REMOVEMULTIALL)
(MACROS FGETMULTI FGETMULTI-PAIR FPUSHMULTI FPUTMULTI FPUSHMULTI-NEW)
(FNS MAPMULTI MAPMULTI1 COLLECTMULTI)
(FNS GETMULTI.EXPAND PUTMULTI.EXPAND)
(MACROS ADDTOMULTI)
(FNS ADDTOMULTI1)
(LOCALVARS . T)))
(DECLARE%: EVAL@COMPILE

(PUTPROPS GETMULTI MACRO [ARGS `(CDR (GETMULTI-PAIR ,@ARGS])

(PUTPROPS GETMULTI-PAIR MACRO (ARGS (GETMULTI.EXPAND 'SASSOC ARGS)))

(PUTPROPS PUSHMULTI MACRO (ARGS (PUTMULTI.EXPAND 'SASSOC ARGS)))

(PUTPROPS PUTMULTI MACRO (ARGS (PUTMULTI.EXPAND 'SASSOC ARGS NIL T)))

(PUTPROPS PUSHMULTI-NEW MACRO (ARGS (PUTMULTI.EXPAND 'SASSOC ARGS)))

(PUTPROPS REMOVEMULTI MACRO [ARGS `(CHANGE [GETMULTI ,@(for ATAIL on ARGS while (CDR ATAIL)
collect (CAR ATAIL]
(REMOVE ,(CAR (LAST ARGS))
DATUM])

(PUTPROPS REMOVEMULTIALL MACRO (ARGS `(RPLACD (GETMULTI-PAIR ,@ARGS)
NIL)))
)
(DECLARE%: EVAL@COMPILE

(PUTPROPS FGETMULTI MACRO [ARGS `(CDR (FGETMULTI-PAIR ,@ARGS])

(PUTPROPS FGETMULTI-PAIR MACRO (ARGS (GETMULTI.EXPAND 'FASSOC ARGS)))

(PUTPROPS FPUSHMULTI MACRO (ARGS (PUTMULTI.EXPAND 'FASSOC ARGS)))

(PUTPROPS FPUTMULTI MACRO (ARGS (PUTMULTI.EXPAND 'FASSOC ARGS)))

(PUTPROPS FPUSHMULTI-NEW MACRO (ARGS (PUTMULTI.EXPAND 'FASSOC ARGS)))
)
(DEFINEQ

(MAPMULTI
[LAMBDA (MULTIALIST MAPFN) (* ; "Edited 29-Jan-2025 19:33 by rmk")
(* ; "Edited 25-Jan-2025 14:51 by rmk")
(* ; "Edited 16-Jan-2025 10:32 by rmk")
(* ; "Edited 6-Jan-2020 10:15 by rmk:")

(* ;; "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.")

(DECLARE (SPECVARS MAPFN))
(LET ($$LISTFORARGS$$)
(DECLARE (SPECVARS $$LISTFORARGS$$))
(SETQ $$LISTFORARGS$$ (FOR I FROM 1 TO (NARGS MAPFN) COLLECT NIL))
(MAPMULTI1 MULTIALIST $$LISTFORARGS$$ (NARGS MAPFN])

(MAPMULTI1
[LAMBDA (SUBALIST ARGLIST NREMAINING) (* ; "Edited 25-Jan-2025 15:03 by rmk")
(* ; "Edited 22-Jan-2025 23:42 by rmk")
(* ; "Edited 16-Jan-2025 10:29 by rmk")
(* ; "Edited 6-Jan-2020 10:21 by rmk:")
(DECLARE (USEDFREE $$LISTFORARGS$$ MAPFN))
(if [AND (IGREATERP NREMAINING 1)
(LISTP (CAR (LISTP SUBALIST]
then
(* ;; "Still a list of alists.")

(for SI in SUBALIST do (RPLACA ARGLIST (CAR SI))
(MAPMULTI1 (CDR SI)
(CDR ARGLIST)
(SUB1 NREMAINING)))
else (for ITEM inside SUBALIST do (RPLACA ARGLIST ITEM)
(APPLY MAPFN $$LISTFORARGS$$])

(COLLECTMULTI
[LAMBDA (MULTIALIST MAPFN) (* ; "Edited 25-Jan-2025 15:00 by rmk")
(* ; "Edited 22-Jan-2025 23:44 by rmk")
(* ; "Edited 6-Jan-2020 10:15 by rmk:")
(LET ($$COLLECT)
(DECLARE (SPECVARS $$COLLECT))
(MAPMULTI MULTIALIST MAPFN)
$$COLLECT])
)
(DEFINEQ

(GETMULTI.EXPAND
[LAMBDA (ASSOCFN ARGS) (* ; "Edited 8-Aug-2025 12:55 by rmk")
(* ; "Edited 14-Jun-2025 09:47 by rmk")
(* ; "Edited 16-Jan-2025 10:27 by rmk")
(* ; "Edited 19-Jul-2020 00:38 by rmk:")
(* ; "Edited 22-Mar-2020 13:21 by rmk:")
(* ; "Edited 27-Feb-2020 13:44 by rmk:")

(* ;; "This returns the last (key . rest) cell (like ASSOC)")

`(LET [($$CELL$$ ,(CAR ARGS]
(DECLARE (LOCALVARS $$CELL$$))
,@(for ATAIL on (CDR ARGS) collect (if (CDR ATAIL)
then `(SETQ $$CELL$$ (CDR (,ASSOCFN
,(CAR ATAIL)
$$CELL$$)))
else `(,ASSOCFN ,(CAR ATAIL)
$$CELL$$])

(PUTMULTI.EXPAND
[LAMBDA (ASSOCFN ARGS ALLOWREPEATS SINGLEVALUE CHANGE) (* ; "Edited 8-Jul-2025 12:52 by rmk")
(* ; "Edited 14-Jun-2025 09:44 by rmk")
(* ; "Edited 23-Jan-2025 09:40 by rmk")
(* ; "Edited 16-Jan-2025 10:18 by rmk")
(* ; "Edited 17-Aug-2020 14:09 by rmk:")

(* ;; "If ALLOWREPEATS, doesn't test (MEMBER) for preexisting values, just accumulates")

(* ;; "If SINGLEVALUE, new value smashes out old")

(* ;; "For CHANGE, the last argument is the change expression to be evaluated, with the current value denoted by the atom DATUM")

(* ;; "")

(* ;; "We get the setf method so that any expressions in the form will be evaluated only once.")

(CL:MULTIPLE-VALUE-BIND
(TEMPVARS VALFORMS STOREVARS STOREFORM ACCESSFORM)
(CL:GET-SETF-METHOD (CAR ARGS))
(if (CDR ARGS)
then
(LET
((VALBINDINGS (FOR VF IN VALFORMS AS TV IN TEMPVARS COLLECT (LIST TV VF)))
EXPANSION)
(SETQ EXPANSION
`(LET
($$ARG1$$ $$ARG2$$)
(DECLARE (LOCALVARS $$ARG1$$ $$ARG2$$))
,@[FOR ATAIL (HEAD _ ACCESSFORM) ON ARGS WHILE (CDR ATAIL)
JOIN
(IF (AND CHANGE (NULL (CDDR ATAIL)))
THEN (POP ATAIL)
[AND NIL `((CL:UNLESS ,HEAD (RPLACD $$ARG1$$ 0))
(SETQ $$ARG2$$ (ADD ,HEAD ,(CAR ATAIL]
`[(SETQ $$ARG2$$ ,(SUBST HEAD 'DATUM (CAR ATAIL]
ELSE
(PROG1 `[(SETQ $$ARG2$$ ,(CADR ATAIL))
,(IF (CDDR ATAIL)
THEN `[SETQ $$ARG1$$ (OR (,ASSOCFN $$ARG2$$ ,HEAD)
(CAR (CL:PUSH (CONS $$ARG2$$)
,HEAD]
ELSEIF ALLOWREPEATS
THEN `(push ,HEAD $$ARG2$$)
ELSEIF SINGLEVALUE
THEN `(CL:SETF ,HEAD $$ARG2$$)
ELSE `(OR (MEMBER $$ARG2$$ ,HEAD)
(push ,HEAD $$ARG2$$]
(SETQ HEAD '(CDR $$ARG1$$)))]
$$ARG2$$))
(CL:IF VALBINDINGS
`(LET* ,VALBINDINGS (DECLARE (LOCALVARS ,@TEMPVARS))
,EXPANSION)
EXPANSION))
else (CAR ARGS])
)
(DECLARE%: EVAL@COMPILE

(PUTPROPS ADDTOMULTI MACRO [ARGS (CL:MULTIPLE-VALUE-BIND
(TEMPVARS VALFORMS STOREVARS STOREFORM ACCESSFORM)
(CL:GET-SETF-METHOD (CAR ARGS))
`(LET* [,@(FOR VF IN VALFORMS AS TV IN TEMPVARS
COLLECT (LIST TV VF))
($$KEYS ,(CADR ARGS]
(DECLARE (LOCALVARS $$KEYS ,@TEMPVARS))
(COND
[(LISTP $$KEYS)
(CL:UNLESS (SASSOC (CAR $$KEYS)
,ACCESSFORM)
(CL:PUSH (CONS (CAR $$KEYS))
,ACCESSFORM))
(ADDTOMULTI1 ,ACCESSFORM $$KEYS ,(CADDR ARGS]
(T (CL:SETF ,ACCESSFORM ,(CADDR ARGS])
)
(DEFINEQ

(ADDTOMULTI1
[LAMBDA (PLACE KEYS VAL) (* ; "Edited 22-Jan-2025 23:47 by rmk")
(* ; "Edited 17-Aug-2020 15:05 by rmk:")

(* ;; "This allows the keys to be provided in a single list rather than as separate arguments.")

(FOR I (P _ PLACE) IN KEYS DO [SETQ P (OR (SASSOC I P)
(CAR (PUSH (CDR P)
(CONS I] FINALLY (PUSH (CDR P)
VAL))
VAL])
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(LOCALVARS . T)
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (2233 4845 (MAPMULTI 2243 . 3311) (MAPMULTI1 3313 . 4370) (COLLECTMULTI 4372 . 4843)) (
4846 9101 (GETMULTI.EXPAND 4856 . 6174) (PUTMULTI.EXPAND 6176 . 9099)) (10251 10936 (ADDTOMULTI1 10261
. 10934)))))
STOP
Binary file added library/MULTI-ALIST.LCOM
View file
Open in desktop
Binary file not shown.
Binary file added library/MULTI-ALIST.TEDIT
View file
Open in desktop
Binary file not shown.