Extensions to MULTI-ALIST especially for PLACE (#2261)
* Extensions to MULTI-ALIST especially for PLACE * Decided to add FETCHMULTI with computed keys parallel to GETMULTI
This commit is contained in:
rmkaplan
GitHub
parent
74f518ca02
commit
f004d43ef1
@ -1,67 +1,99 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "10-Jul-2025 12:37:33" {WMEDLEY}<lispusers>MULTI-ALIST.;19 12851
|
||||
(FILECREATED "15-Aug-2025 23:02:22" {WMEDLEY}<library>MULTI-ALIST.;23 15006
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (VARS MULTI-ALISTCOMS)
|
||||
(MACROS PUSHMULTI PUTMULTI PUSHMULTI-NEW FPUSHMULTI FPUSHMULTI-NEW)
|
||||
(MACROS FETCHMULTI)
|
||||
|
||||
:PREVIOUS-DATE " 8-Jul-2025 12:54:37" {WMEDLEY}<lispusers>MULTI-ALIST.;18)
|
||||
:PREVIOUS-DATE "15-Aug-2025 08:31:28" {WMEDLEY}<library>MULTI-ALIST.;22)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT MULTI-ALISTCOMS)
|
||||
|
||||
(RPAQQ MULTI-ALISTCOMS
|
||||
((MACROS GETMULTI PUSHMULTI PUTMULTI PUSHMULTI-NEW CHANGEMULTI REMOVEMULTI REMOVEMULTIALL)
|
||||
(MACROS FGETMULTI FPUSHMULTI FPUTMULTI FPUSHMULTI-NEW FCHANGEMULTI)
|
||||
(FNS MAPMULTI MAPMULTI1 COLLECTMULTI)
|
||||
(FNS GETMULTI.EXPAND PUTMULTI.EXPAND REMOVEMULTI.EXPAND)
|
||||
(MACROS ADDTOMULTI)
|
||||
(FNS ADDTOMULTI1)
|
||||
((MACROS PUSHMULTI PUTMULTI PUSHMULTI-NEW FPUSHMULTI FPUTMULTI FPUSHMULTI-NEW STOREMULTI)
|
||||
(MACROS GETMULTI GETMULTI-PAIR FGETMULTI FGETMULTI-PAIR FETCHMULTI)
|
||||
(MACROS REMOVEMULTI REMOVEMULTI-ALL)
|
||||
(FNS MAPMULTI MAPMULTI1 COLLECTMULTI FETCHMULTI-PAIR EXTENDMULTI-PAIR)
|
||||
(FNS GETMULTI-PAIR.EXPAND PUTMULTI.EXPAND)
|
||||
(PROP ARGNAMES PUSHMULTI PUTMULTI PUSHMULTI-NEW REMOVEMULTI FPUSHMULTI FPUTMULTI
|
||||
FPUSHMULTI-NEW STOREMULTI)
|
||||
(LOCALVARS . T)))
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS GETMULTI MACRO (ARGS (GETMULTI.EXPAND 'SASSOC ARGS)))
|
||||
(PUTPROPS PUSHMULTI MACRO (ARGS (PUTMULTI.EXPAND ARGS 'SASSOC 'PUSH)))
|
||||
|
||||
(PUTPROPS PUSHMULTI MACRO (ARGS (PUTMULTI.EXPAND 'SASSOC ARGS)))
|
||||
(PUTPROPS PUTMULTI MACRO (ARGS (PUTMULTI.EXPAND ARGS 'SASSOC 'PUT)))
|
||||
|
||||
(PUTPROPS PUTMULTI MACRO (ARGS (PUTMULTI.EXPAND 'SASSOC ARGS NIL T)))
|
||||
(PUTPROPS PUSHMULTI-NEW MACRO (ARGS (PUTMULTI.EXPAND ARGS 'SASSOC 'PUSHNEW)))
|
||||
|
||||
(PUTPROPS PUSHMULTI-NEW MACRO (ARGS (PUTMULTI.EXPAND 'SASSOC ARGS)))
|
||||
(PUTPROPS FPUSHMULTI MACRO (ARGS (PUTMULTI.EXPAND ARGS 'ASSOC 'PUSH)))
|
||||
|
||||
(PUTPROPS CHANGEMULTI MACRO (ARGS (PUTMULTI.EXPAND 'SASSOC ARGS NIL NIL T)))
|
||||
(PUTPROPS FPUTMULTI MACRO (ARGS (PUTMULTI.EXPAND ARGS 'ASSOC 'PUT)))
|
||||
|
||||
(PUTPROPS REMOVEMULTI MACRO (ARGS (REMOVEMULTI.EXPAND ARGS)))
|
||||
(PUTPROPS FPUSHMULTI-NEW MACRO (ARGS (PUTMULTI.EXPAND ARGS 'ASSOC 'PUSHNEW)))
|
||||
|
||||
(PUTPROPS REMOVEMULTIALL MACRO (ARGS (REMOVEMULTI.EXPAND ARGS T)))
|
||||
(PUTPROPS STOREMULTI MACRO
|
||||
[ARGS (LET ((PLACE (CAR ARGS))
|
||||
(KEYS (CADR ARGS))
|
||||
(VAL (CADDR ARGS))
|
||||
(OPTIONS (CADDDR ARGS)))
|
||||
(CL:MULTIPLE-VALUE-BIND
|
||||
(TEMPVARS VALFORMS STOREVARS STOREFORM ACCESSFORM)
|
||||
(CL:GET-SETF-METHOD PLACE)
|
||||
`(LET (,@(FOR VF IN VALFORMS AS TV IN TEMPVARS COLLECT (LIST TV VF))
|
||||
($$KEYS$$ ,KEYS))
|
||||
(DECLARE (LOCALVARS $$KEYS$$ ,@TEMPVARS))
|
||||
(EXTENDMULTI-PAIR [OR ,ACCESSFORM (CL:SETF ,ACCESSFORM
|
||||
(CONS (CONS (CAR $$KEYS$$]
|
||||
$$KEYS$$
|
||||
,VAL
|
||||
,OPTIONS])
|
||||
)
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS FGETMULTI MACRO (ARGS (GETMULTI.EXPAND 'FASSOC ARGS)))
|
||||
(PUTPROPS GETMULTI MACRO ((MULTIALIST . KEYS)
|
||||
(CDR (GETMULTI-PAIR MULTIALIST . KEYS))))
|
||||
|
||||
(PUTPROPS FPUSHMULTI MACRO (ARGS (PUTMULTI.EXPAND 'FASSOC ARGS)))
|
||||
(PUTPROPS GETMULTI-PAIR MACRO (ARGS (GETMULTI-PAIR.EXPAND 'SASSOC (CAR ARGS)
|
||||
(CDR ARGS))))
|
||||
|
||||
(PUTPROPS FPUTMULTI MACRO (ARGS (PUTMULTI.EXPAND 'FASSOC ARGS)))
|
||||
(PUTPROPS FGETMULTI MACRO ((MULTIALIST . KEYS)
|
||||
(CDR (FGETMULTI-PAIR MULTIALIST . KEYS))))
|
||||
|
||||
(PUTPROPS FPUSHMULTI-NEW MACRO (ARGS (PUTMULTI.EXPAND 'FASSOC ARGS)))
|
||||
(PUTPROPS FGETMULTI-PAIR MACRO (ARGS (GETMULTI-PAIR.EXPAND 'ASSOC (CAR ARGS)
|
||||
(CDR ARGS))))
|
||||
|
||||
(PUTPROPS FCHANGEMULTI MACRO (ARGS (PUTMULTI.EXPAND 'FASSOC ARGS NIL NIL T)))
|
||||
(PUTPROPS FETCHMULTI MACRO ((MULTIALIST KEYS FAST)
|
||||
(CDR (FETCHMULTI-PAIR MULTIALIST KEYS FAST))))
|
||||
)
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS REMOVEMULTI MACRO [ARGS `(CHANGE [GETMULTI ,@(for ATAIL on ARGS while (CDR ATAIL)
|
||||
collect (CAR ATAIL]
|
||||
(REMOVE ,(CAR (LAST ARGS))
|
||||
DATUM])
|
||||
|
||||
(PUTPROPS REMOVEMULTI-ALL MACRO ((MULTIALIST . KEYS)
|
||||
(RPLACD (GETMULTI-PAIR MULTIALIST . KEYS)
|
||||
NIL)))
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(MAPMULTI
|
||||
[LAMBDA (MULTIALIST MAPFN) (* ; "Edited 29-Jan-2025 19:33 by rmk")
|
||||
[LAMBDA (MULTIALIST MAPFN) (* ; "Edited 12-Aug-2025 11:15 by rmk")
|
||||
(* ; "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.")
|
||||
(* ;; "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 (PUTMULT 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$$)
|
||||
(LET (($$LISTFORARGS$$ (for I from 1 to (NARGS MAPFN) collect NIL)))
|
||||
(DECLARE (SPECVARS $$LISTFORARGS$$))
|
||||
(SETQ $$LISTFORARGS$$ (FOR I FROM 1 TO (NARGS MAPFN) COLLECT NIL))
|
||||
(MAPMULTI1 MULTIALIST $$LISTFORARGS$$ (NARGS MAPFN])
|
||||
|
||||
(MAPMULTI1
|
||||
@ -90,159 +122,158 @@
|
||||
(DECLARE (SPECVARS $$COLLECT))
|
||||
(MAPMULTI MULTIALIST MAPFN)
|
||||
$$COLLECT])
|
||||
|
||||
(FETCHMULTI-PAIR
|
||||
[LAMBDA (MULTIALIST KEYS FAST) (* ; "Edited 15-Aug-2025 08:08 by rmk")
|
||||
(* ; "Edited 13-Aug-2025 13:30 by rmk")
|
||||
|
||||
(* ;; "Parallel to GETMULTI-PAIR but with the keys in a computed list. ")
|
||||
|
||||
(CL:UNLESS (LISTP KEYS)
|
||||
(ERROR (ERROR "FETCHMULTI-PAIR requires at least 1 key" KEYS)))
|
||||
(for KTAIL (LASTPAIR _ (CL:IF FAST
|
||||
(ASSOC (CAR KEYS)
|
||||
MULTIALIST)
|
||||
(SASSOC (CAR KEYS)
|
||||
MULTIALIST))) on (CDR KEYS)
|
||||
do (SETQ LASTPAIR (CL:IF FAST
|
||||
(ASSOC (CAR KTAIL)
|
||||
LASTPAIR)
|
||||
(SASSOC (CAR KTAIL)
|
||||
LASTPAIR))) finally (RETURN LASTPAIR])
|
||||
|
||||
(EXTENDMULTI-PAIR
|
||||
[LAMBDA (MULTIALIST KEYS VAL OPTIONS) (* ; "Edited 15-Aug-2025 08:08 by rmk")
|
||||
(* ; "Edited 13-Aug-2025 14:39 by rmk")
|
||||
(* ; "Edited 22-Jan-2025 23:47 by rmk")
|
||||
(* ; "Edited 17-Aug-2020 15:05 by rmk:")
|
||||
|
||||
(* ;; "Extends the multi-alist that the caller has rooted at FIRSTPAIR (whose key is presumably (CAR LASTPAIR)). Returns the pair, new or existing, that is headed by the last key. ")
|
||||
|
||||
(* ;; "There has to be a structure to add to, even at the root. Otherwise, if we were to make a completely new list and return its last pair, the new list would drop on the floor. ")
|
||||
|
||||
(CL:UNLESS (LISTP (CAR (LISTP MULTIALIST)))
|
||||
(ERROR MULTIALIST "is not a MULTI-ALIST"))
|
||||
(CL:UNLESS (LISTP KEYS)
|
||||
(ERROR "EXTENDMULTI-PAIR requires at least 1 key" KEYS))
|
||||
(for K LASTPAIR (FAST _ (EQMEMB 'FAST OPTIONS)) in (CDR KEYS)
|
||||
first [SETQ LASTPAIR (OR (CL:IF FAST
|
||||
(ASSOC (CAR KEYS)
|
||||
MULTIALIST)
|
||||
(SASSOC (CAR KEYS)
|
||||
MULTIALIST))
|
||||
(CAR (ATTACH (CONS (CAR KEYS))
|
||||
MULTIALIST]
|
||||
|
||||
(* ;; "We have insured a pair headed by (CAR KEYS) at the top level of MULTIALIST.")
|
||||
do [SETQ LASTPAIR (OR (CL:IF FAST
|
||||
(ASSOC K (CDR LASTPAIR))
|
||||
(SASSOC K (CDR LASTPAIR)))
|
||||
(CAR (PUSH (CDR LASTPAIR)
|
||||
(CONS K] finally (CL:UNLESS (LISTP LASTPAIR)
|
||||
(ERROR "INVALID MULTI-ALIST" (LIST LASTPAIR
|
||||
KEYS)))
|
||||
(if (EQMEMB 'PUSH OPTIONS)
|
||||
then (CL:UNLESS (MEMBER VAL (CDR LASTPAIR))
|
||||
(CL:PUSH VAL (CDR LASTPAIR)))
|
||||
elseif (EQMEMB 'PUSHNEW OPTIONS)
|
||||
then (CL:PUSH VAL (CDR LASTPAIR))
|
||||
else (RPLACD LASTPAIR VAL))
|
||||
(* ; "Should it return LASTPAIR?")
|
||||
(RETURN VAL])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(GETMULTI.EXPAND
|
||||
[LAMBDA (ASSOCFN ARGS) (* ; "Edited 14-Jun-2025 09:47 by rmk")
|
||||
(GETMULTI-PAIR.EXPAND
|
||||
[LAMBDA (ASSOCFN PLACE KEYS) (* ; "Edited 11-Aug-2025 09:56 by rmk")
|
||||
(* ; "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:")
|
||||
(* ; "Edited 30-Dec-2019 20:50 by rmk:")
|
||||
(* ; "Edited 27-Feb-2020 13:44 by rmk:")
|
||||
|
||||
(* ;; "If SUM, returns the value after the last argument, paired with PUTMULTISUM")
|
||||
(* ;;
|
||||
"This returns the last (key . rest) cell (like ASSOC), NIL if no keys and place is not a list")
|
||||
|
||||
(IF (CDR ARGS)
|
||||
THEN `(LET ($$CELL$$)
|
||||
(DECLARE (LOCALVARS $$CELL$$))
|
||||
,@[FOR ATAIL (HEAD _ (CAR ARGS)) ON (CDR ARGS)
|
||||
COLLECT (PROG1 `[SETQ $$CELL$$ (CDR (,ASSOCFN ,(CAR ATAIL)
|
||||
,HEAD]
|
||||
(SETQ HEAD '$$CELL$$))]
|
||||
$$CELL$$)
|
||||
ELSE (CAR ARGS])
|
||||
(if KEYS
|
||||
then `[LET (($$PAIR$$ ,PLACE))
|
||||
(DECLARE (LOCALVARS $$PAIR$$))
|
||||
,@(for KTAIL on KEYS
|
||||
collect (if (CDR KTAIL)
|
||||
then `(SETQ $$PAIR$$ (CDR (,ASSOCFN ,(CAR KTAIL)
|
||||
$$PAIR$$)))
|
||||
else `(,ASSOCFN ,(CAR KTAIL)
|
||||
$$PAIR$$]
|
||||
else (ERROR "GETMULTI requires at least 1 key" (CONS PLACE KEYS])
|
||||
|
||||
(PUTMULTI.EXPAND
|
||||
[LAMBDA (ASSOCFN ARGS ALLOWREPEATS SINGLEVALUE CHANGE) (* ; "Edited 8-Jul-2025 12:52 by rmk")
|
||||
[LAMBDA (ARGS ASSOCFN OP) (* ; "Edited 14-Aug-2025 22:40 by rmk")
|
||||
(* ; "Edited 13-Aug-2025 14:42 by rmk")
|
||||
(* ; "Edited 11-Aug-2025 21:43 by rmk")
|
||||
(* ; "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")
|
||||
(* ;; "We get the setf method so that any expressions in the place will be evaluated only once. It may have internal forms that bind to temporary variables (which must come first, for evaluation order.")
|
||||
|
||||
(* ;; "If SINGLEVALUE, new value smashes out old")
|
||||
(if (CDDR ARGS)
|
||||
then
|
||||
[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))
|
||||
$$PAIR$$ $$KEY$$ $$VAL)
|
||||
(DECLARE (LOCALVARS $$PAIR$$ $$KEY$$ $$VAL ,@TEMPVARS))
|
||||
,@(for KTAIL (HEAD _ ACCESSFORM) on (CDR ARGS)
|
||||
join (if (CDR KTAIL)
|
||||
then
|
||||
(* ;; "Is HEAD so that CL:PUSH gets PLACE")
|
||||
|
||||
(* ;; "For CHANGE, the last argument is the change expression to be evaluated, with the current value denoted by the atom DATUM")
|
||||
(PROG1 `[(SETQ $$KEY$$ ,(CAR KTAIL))
|
||||
(SETQ $$PAIR$$ (OR (,ASSOCFN $$KEY$$ ,HEAD)
|
||||
(CAR (CL:PUSH (CONS $$KEY$$)
|
||||
,HEAD]
|
||||
(SETQ HEAD '(CDR $$PAIR$$)))
|
||||
else
|
||||
(* ;; "Last one is the value, it hits the CDR of $$PAIR$$.")
|
||||
|
||||
(* ;; "")
|
||||
|
||||
(* ;; "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])
|
||||
|
||||
(REMOVEMULTI.EXPAND
|
||||
[LAMBDA (ARGS ALLFLAG) (* ; "Edited 16-Jan-2025 10:34 by rmk")
|
||||
(* ; "Edited 17-Aug-2020 15:12 by rmk:")
|
||||
(* ; "Edited 17-May-2020 17:25 by rmk:")
|
||||
(* ; "Edited 14-Feb-2020 11:24 by rmk:")
|
||||
(* ; "Edited 25-Dec-2019 09:57 by rmk:")
|
||||
|
||||
(* ;; "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.")
|
||||
|
||||
(* ;; "No point in distinguishing FASSOC from SASSOC here.")
|
||||
|
||||
(CL:MULTIPLE-VALUE-BIND
|
||||
(TEMPVARS VALFORMS STOREVARS STOREFORM ACCESSFORM)
|
||||
(CL:GET-SETF-METHOD (CAR ARGS))
|
||||
(CL:IF (CDR ARGS)
|
||||
`(LET*
|
||||
,(FOR VF IN VALFORMS AS TV IN TEMPVARS COLLECT (LIST TV VF))
|
||||
(DECLARE (LOCALVARS ,@TEMPVARS))
|
||||
(LET
|
||||
($$ARG1$$ $$ARG2$$)
|
||||
(DECLARE (LOCALVARS $$ARG1$$ $$ARG2$$))
|
||||
,@[FOR ATAIL (HEAD _ ACCESSFORM) ON ARGS WHILE (CDR ATAIL)
|
||||
JOIN (PROG1 `[(SETQ $$ARG2$$ ,(CADR ATAIL))
|
||||
,(IF (CDDR ATAIL)
|
||||
THEN `(SETQ $$ARG1$$ (SASSOC $$ARG2$$ ,HEAD))
|
||||
ELSEIF ALLFLAG
|
||||
THEN `(CL:WHEN (SETQ $$ARG1$$ (SASSOC $$ARG2$$ ,HEAD))
|
||||
(SETQ $$ARG2$$ (CDR $$ARG1$$))
|
||||
(RPLACD $$ARG1$$))
|
||||
ELSE `(AND (SETQ $$ARG2$$ (MEMBER $$ARG2$$ ,HEAD))
|
||||
(RPLACD $$ARG1$$ (DREMOVE (SETQ $$ARG2$$ (CAR $$ARG2$$))
|
||||
,HEAD]
|
||||
(SETQ HEAD '(CDR $$ARG1$$)))]
|
||||
$$ARG2$$))
|
||||
(CAR ARGS))])
|
||||
(SELECTQ OP
|
||||
(PUT `[(CDR (RPLACD $$PAIR$$ ,(CAR KTAIL])
|
||||
(PUSH `[(CAR (CL:PUSH ,(CAR KTAIL)
|
||||
(CDR $$PAIR$$])
|
||||
(PUSHNEW `((SETQ $$VAL ,(CAR KTAIL))
|
||||
(OR (MEMBER $$VAL (CDR $$PAIR$$))
|
||||
(CL:PUSH $$VAL (CDR $$PAIR$$)))
|
||||
$$VAL))
|
||||
(SHOULDN'T]
|
||||
else (ERROR "PUTMULTI requires at least 1 key" 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
|
||||
(PUTPROPS PUSHMULTI ARGNAMES (PLACE KEY1...KEYN VAL))
|
||||
|
||||
(ADDTOMULTI1
|
||||
[LAMBDA (PLACE KEYS VAL) (* ; "Edited 22-Jan-2025 23:47 by rmk")
|
||||
(* ; "Edited 17-Aug-2020 15:05 by rmk:")
|
||||
(PUTPROPS PUTMULTI ARGNAMES (PLACE KEY1...KEYN VAL))
|
||||
|
||||
(* ;; "This allows the keys to be provided in a single list rather than as separate arguments.")
|
||||
(PUTPROPS PUSHMULTI-NEW ARGNAMES (PLACE KEY1...KEYN VAL))
|
||||
|
||||
(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])
|
||||
)
|
||||
(PUTPROPS REMOVEMULTI ARGNAMES (MULTIALIST KEY1...KEYN VAL))
|
||||
|
||||
(PUTPROPS FPUSHMULTI ARGNAMES (PLACE KEY1...KEYN VAL))
|
||||
|
||||
(PUTPROPS FPUTMULTI ARGNAMES (PLACE KEY1...KEYN VAL))
|
||||
|
||||
(PUTPROPS FPUSHMULTI-NEW ARGNAMES (PLACE KEY1...KEYN VAL))
|
||||
|
||||
(PUTPROPS STOREMULTI ARGNAMES (PLACE KEYS VAL OPTIONS))
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(LOCALVARS . T)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1845 4457 (MAPMULTI 1855 . 2923) (MAPMULTI1 2925 . 3982) (COLLECTMULTI 3984 . 4455)) (
|
||||
4458 10939 (GETMULTI.EXPAND 4468 . 5698) (PUTMULTI.EXPAND 5700 . 8623) (REMOVEMULTI.EXPAND 8625 .
|
||||
10937)) (12089 12774 (ADDTOMULTI1 12099 . 12772)))))
|
||||
(FILEMAP (NIL (3610 10036 (MAPMULTI 3620 . 4766) (MAPMULTI1 4768 . 5825) (COLLECTMULTI 5827 . 6298) (
|
||||
FETCHMULTI-PAIR 6300 . 7247) (EXTENDMULTI-PAIR 7249 . 10034)) (10037 14407 (GETMULTI-PAIR.EXPAND 10047
|
||||
. 11544) (PUTMULTI.EXPAND 11546 . 14405)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
Binary file not shown.
Loading…
x
Reference in New Issue
Block a user