Trailing-Edge
-
PDP-10 Archives
-
-
There are no other files named in the archive.
(FILECREATED "11-JUL-82 23:41:59" <LISPUSERS>SIMPLEFNS.;5 8475
changes to: (VARS SIMPLEFNSCOMS)
previous date: " 2-MAR-82 09:09:24" <LISPUSERS>SIMPLEFNS.;4)
(PRETTYCOMPRINT SIMPLEFNSCOMS)
(RPAQQ SIMPLEFNSCOMS [(DECLARE: EVAL@COMPILE DONTCOPY (P (RESETSAVE DWIMIFYCOMPFLG T)))
(FNS COMBINATIONS DKILL DKILLQ FILE FIRSTPART IFF KILL LEAVES SEARCH SINGLES
STRINGSUBST SUBSETP UNATTACH)
(PROP MACRO IFF)
(COMS (FNS OCCURRENCES OCCURRENCES1)
(BLOCKS (OCCURRENCES OCCURRENCES OCCURRENCES1)))
(LOCALVARS . T)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA FILE)
(NLAML DKILLQ)
(LAMA])
(DECLARE: EVAL@COMPILE DONTCOPY
(RESETSAVE DWIMIFYCOMPFLG T)
)
(DEFINEQ
(COMBINATIONS
[LAMBDA (CLIST) (* Computes the cross product of a list of lists)
(if CLIST::1
then (for Y in (COMBINATIONS CLIST::1) join (for X in CLIST:1 collect <X ! Y>))
else (for X in CLIST:1 collect <X>])
(DKILL
[LAMBDA (X L)
(CLISP: FAST) (* Dremoves first X from L; OK if L circular)
(if (NLISTP L)
then L
elseif X=L:1
then (if L=L::1
then (* Only element in circular list)
((L:1_NIL)::1_NIL)
NIL
elseif L::1
then ((L:1_L:2)::1_L::2)
else L:1_NIL
NIL)
else (PROG ((Z L))
LP (if (NLISTP Z::1)
elseif X=Z:2
then (Z::1_Z::2)
elseif L~=Z_Z::1
then (GO LP))
(RETURN L])
(DKILLQ
[NLAMBDA (X L)
(DKILL X (EVAL L])
(FILE
[NLAMBDA ARGS
(CLISP:(RECORD ARGRECORD (FILE . COMS))) (* rmk: "25-JUL-79 23:34")
(* A convenient way of calling MAKEFILE. ARGS::1 can be a list of commands that fileCOMS will be set to. If the only command is a single
atom, then its value will be taken as the command list.)
(if ARGS:COMS
then (/SETATOMVAL (FILECOMS ARGS:FILE)
(if (AND (LITATOM ARGS:COMS:1)
ARGS:COMS::1=NIL)
then (GETATOMVAL ARGS:COMS:1)
else ARGS:COMS)))
(RESETFORM (RADIX 10)
(MAKEFILE ARGS:FILE])
(FIRSTPART
[LAMBDA (WHOLE TAIL) (* If TAIL is a tail of WHOLE, FIRSTPART returns VAL such
that WHOLE equals (APPEND VAL TAIL))
(AND WHOLE_(LASTN WHOLE (LENGTH TAIL))
(EQUAL TAIL WHOLE::1)
WHOLE:1])
(IFF
[LAMBDA (ARG1 ARG2) (* Test ARG1 iff ARG2. Macroed)
~ARG1=~ARG2])
(KILL
[LAMBDA (ELT LIST) (* rmk: "22-DEC-76 23:19:26")
(* REMOVES first ELT from LIST -- using EQ)
(if (NLISTP LIST)
then LIST
elseif ELT=LIST:1
then LIST::1
else <LIST:1 ! (KILL ELT LIST::1)>])
(LEAVES
[LAMBDA (X) (* Computes list of leaves (terminal atoms) of a list
structure)
(if (NLISTP X)
then <X>
else (for Y in X join LEAVES])
(SEARCH
[LAMBDA (ELT STRUCT) (* rmk: " 8-MAY-77 16:42")
(* Like MEMB but looks at all levels of structure STRUCT)
(for S on STRUCT do (if ELT=S:1
then (RETURN S)
elseif $$VAL_(SEARCH ELT S:1)
then (RETURN $$VAL])
(SINGLES
[LAMBDA (LST)
(CLISP: FAST) (* Eliminates list duplicates)
(if (LISTP LST)
then (for ELT in old LST unless (if (LITATOM ELT)
then (* Saves function call for atoms)
(FMEMB ELT $$VAL)
else ELT MEMBER $$VAL)
fcollect ELT finally ($$TEM2::1_LST))
else LST])
(STRINGSUBST
[LAMBDA (NEW OLD STRING COPYFLG) (* rmk: "17-DEC-78 20:17")
(* Replaces OLD with NEW in STRING, returning the changed result. If OLD doesn't appear, returns STRING. If COPYFLG=T, guarantees both a
new string pointer and new chars, so that STRING is unchanged and the value may be smashed without harming STRING.
If COPYFLG=NIL, new storage might or might not be allocated depending on the lengths of NEW and OLD.)
(if ~(STRINGP OLD)
then (OLD_(MKSTRING OLD)))
(PROG ((NEWLEN (NCHARS NEW))
(OLDLEN (NCHARS OLD)))
[if (IEQP NEWLEN OLDLEN)
then (STRING_(if COPYFLG
then (CONCAT STRING)
else (MKSTRING STRING)))
(bind N_1 while N_(STRPOS OLD STRING N) do (RPLSTRING STRING N NEW)
(N_N+NEWLEN)
(* Don't substitute inside the new NEW))
elseif NEWLEN lt OLDLEN
then (STRING_(if COPYFLG
then (CONCAT STRING)
else (MKSTRING STRING)))
(* We try to move the characters around directly in STRING)
(bind TEM N_1
(SHORT_NEWLEN-OLDLEN-1) while N_(STRPOS OLD STRING N)
do (RPLSTRING STRING N NEW)
(if TEM_(SUBSTRING STRING N+OLDLEN NIL (CONSTANT (CONCAT)))
then (RPLSTRING STRING N+NEWLEN TEM))
(SUBSTRING STRING 1 SHORT STRING)
(* Shorten the string)
(N_N+NEWLEN))
else (* The result will be longer than the original, so we have to allocate
like crazy)
(STRING_(bind TEM N_1 first [if (STRPOS OLD STRING)
then STRING_(CONCAT STRING)
else (RETURN (if COPYFLG
then (CONCAT STRING)
else (MKSTRING STRING]
while N join (if TEM_[SUBSTRING STRING N (if N_(STRPOS OLD STRING N)
then (PROG1 N-1
(add N OLDLEN]
then <TEM !(if N
then <NEW>)
>
elseif N
then <NEW>)
finally (RETURN (APPLY (FUNCTION CONCAT)
$$VAL]
(RETURN STRING])
(SUBSETP
[LAMBDA (SMALL LARGE) (* rmk: " 2-MAR-82 09:09")
(* Tests if SMALL is a subset of LARGE)
(for ELT in SMALL unless (MEMBER ELT LARGE) do (RETURN NIL) finally (RETURN T])
(UNATTACH
[LAMBDA (L) (* rmk: " 5-DEC-77 15:49")
(* UNATTACH:ATTACH :: CDR:CONS.
I.e, value is EQ to L but EQUAL to CDR L)
(AND (LISTP L)
(FRPLACD (FRPLACA L L:2)
L::2])
)
(PUTPROPS IFF MACRO ((ARG1 ARG2)
(EQ (NOT ARG1)
(NOT ARG2))))
(DEFINEQ
(OCCURRENCES
[LAMBDA (ITEM STRUCTURE) (* rmk: "30-SEP-77 08:46")
(* Counts the number of times that ITEM is EQ to some element
of STRUCTURE)
(DECLARE (SPECVARS ITEM))
(PROG ((COUNT 0))
(DECLARE (SPECVARS COUNT))
(OCCURRENCES1 STRUCTURE)
(RETURN COUNT])
(OCCURRENCES1
[LAMBDA (STRUCTURE) (* rmk: "30-SEP-77 08:52")
(DECLARE (USEDFREE ITEM COUNT))
(if ITEM=STRUCTURE
then (COUNT_COUNT+1)
elseif (NLISTP STRUCTURE)
else (OCCURRENCES1 STRUCTURE:1)
(OCCURRENCES1 STRUCTURE::1])
)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: OCCURRENCES OCCURRENCES OCCURRENCES1)
]
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA FILE)
(ADDTOVAR NLAML DKILLQ)
(ADDTOVAR LAMA )
)
(DECLARE: DONTCOPY
(FILEMAP (NIL (796 7292 (COMBINATIONS 808 . 1131) (DKILL 1135 . 1767) (DKILLQ 1771 . 1828) (FILE 1832
. 2439) (FIRSTPART 2443 . 2713) (IFF 2717 . 2836) (KILL 2840 . 3186) (LEAVES 3190 . 3438) (SEARCH 3442
. 3816) (SINGLES 3820 . 4240) (STRINGSUBST 4244 . 6665) (SUBSETP 6669 . 6973) (UNATTACH 6977 . 7289))
(7376 8145 (OCCURRENCES 7388 . 7816) (OCCURRENCES1 7820 . 8142)))))
STOP