diff --git a/library/MULTI-ALIST b/library/MULTI-ALIST new file mode 100644 index 000000000..7df2a3a52 --- /dev/null +++ b/library/MULTI-ALIST @@ -0,0 +1,218 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) + +(FILECREATED " 8-Aug-2025 12:59:32"  +{DSK}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}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 diff --git a/library/MULTI-ALIST.LCOM b/library/MULTI-ALIST.LCOM new file mode 100644 index 000000000..9c05f28ac Binary files /dev/null and b/library/MULTI-ALIST.LCOM differ diff --git a/library/MULTI-ALIST.TEDIT b/library/MULTI-ALIST.TEDIT new file mode 100644 index 000000000..87392e998 Binary files /dev/null and b/library/MULTI-ALIST.TEDIT differ