diff --git a/changelog b/changelog index a7720e6..e8a7e87 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,7 @@ +20090816 tpd src/axiom-website/patches.html 20090816.08.tpd.patch +20090816 tpd src/interp/Makefile move g-util.boot to g-util.lisp +20090816 tpd src/interp/g-util.lisp added, rewritten from g-util.boot +20090816 tpd src/interp/g-util.boot removed, rewritten to g-util.lisp 20090816 tpd src/axiom-website/patches.html 20090816.07.tpd.patch 20090816 tpd src/interp/Makefile move g-timer.boot to g-timer.lisp 20090816 tpd src/interp/g-timer.lisp added, rewritten from g-timer.boot diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 1fbc068..de3629c 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -1810,6 +1810,8 @@ g-error.lisp rewrite from boot to lisp
g-opt.lisp rewrite from boot to lisp
20090816.07.tpd.patch g-timer.lisp rewrite from boot to lisp
+20090816.08.tpd.patch +g-util.lisp rewrite from boot to lisp
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index 2c3e81d..cdbc96d 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -424,7 +424,7 @@ DOCFILES=${DOC}/as.boot.dvi \ ${DOC}/foam_l.lisp.dvi \ ${DOC}/fortcall.boot.dvi \ ${DOC}/functor.boot.dvi \ - ${DOC}/g-util.boot.dvi ${DOC}/hashcode.boot.dvi \ + ${DOC}/hashcode.boot.dvi \ ${DOC}/htcheck.boot.dvi \ ${DOC}/ht-util.boot.dvi \ ${DOC}/i-analy.boot.dvi ${DOC}/i-code.boot.dvi \ @@ -731,7 +731,7 @@ ${DEPSYS}: ${DEP} ${OUT}/sys-pkg.${LISP} ${OUT}/nocompil.${LISP} \ ${OUT}/newaux.${LISP} \ ${OUT}/postprop.${LISP} \ ${OUT}/g-boot.lisp ${OUT}/c-util.${LISP} \ - ${OUT}/g-util.${LISP} \ + ${OUT}/g-util.lisp \ ${OUT}/clam.lisp \ ${OUT}/slam.${LISP} ${LOADSYS} @ echo 3 making ${DEPSYS} @@ -777,7 +777,7 @@ ${DEPSYS}: ${DEP} ${OUT}/sys-pkg.${LISP} ${OUT}/nocompil.${LISP} \ ':output-file "${OUT}/c-util.${O}"))' >> ${OUT}/makedep.lisp @ echo '(load "${OUT}/c-util")' >> ${OUT}/makedep.lisp @ echo '(unless (probe-file "${OUT}/g-util.${O}")' \ - '(compile-file "${OUT}/g-util.${LISP}"' \ + '(compile-file "${OUT}/g-util.lisp"' \ ':output-file "${OUT}/g-util.${O}"))' >> ${OUT}/makedep.lisp @ echo '(load "${OUT}/g-util")' >> ${OUT}/makedep.lisp <> @@ -2996,62 +2996,34 @@ ${MID}/g-timer.lisp: ${IN}/g-timer.lisp.pamphlet @ -\subsection{g-util.boot} -Note that the {\bf g-util.boot.pamphlet} file contains both the -original {\bf boot} code and a saved copy of the {\bf g-util.clisp} -code. We need to keep the translated code around so we can bootstrap -the system. In other words, we need this boot code translated so we -can build the boot translator. - -{\bf note: if you change the boot code in g-util.boot.pamphlet -you must translate this code to lisp and store the resulting lisp -code back into the g-util.boot.pamphlet file. this is not automated.} -<>= -${OUT}/g-util.${LISP}: ${IN}/g-util.boot.pamphlet - @ echo 272 making ${OUT}/g-util.${LISP} from ${IN}/g-util.boot.pamphlet - @ rm -f ${OUT}/g-util.${O} - @( cd ${OUT} ; \ - ${TANGLE} -Rg-util.clisp ${IN}/g-util.boot.pamphlet >g-util.${LISP} ) - -@ +\subsection{g-util.lisp} <>= -${OUT}/g-util.${O}: ${MID}/g-util.clisp - @ echo 273 making ${OUT}/g-util.${O} from ${MID}/g-util.clisp - @ (cd ${MID} ; \ +${OUT}/g-util.${O}: ${MID}/g-util.lisp + @ echo 136 making ${OUT}/g-util.${O} from ${MID}/g-util.lisp + @ ( cd ${MID} ; \ if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/g-util.clisp"' \ + echo '(progn (compile-file "${MID}/g-util.lisp"' \ ':output-file "${OUT}/g-util.${O}") (${BYE}))' | ${DEPSYS} ; \ else \ - echo '(progn (compile-file "${MID}/g-util.clisp"' \ + echo '(progn (compile-file "${MID}/g-util.lisp"' \ ':output-file "${OUT}/g-util.${O}") (${BYE}))' | ${DEPSYS} \ >${TMP}/trace ; \ fi ) @ -<>= -${MID}/g-util.clisp: ${IN}/g-util.boot.pamphlet - @ echo 274 making ${MID}/g-util.clisp from ${IN}/g-util.boot.pamphlet +<>= +${MID}/g-util.lisp: ${IN}/g-util.lisp.pamphlet + @ echo 137 making ${MID}/g-util.lisp from ${IN}/g-util.lisp.pamphlet @ (cd ${MID} ; \ - ${TANGLE} ${IN}/g-util.boot.pamphlet >g-util.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "g-util.boot") (${BYE}))' \ - | ${DEPSYS} ; \ - else \ - echo '(progn (boottran::boottocl "g-util.boot") (${BYE}))' \ - | ${DEPSYS} >${TMP}/trace ; \ - fi ; \ - rm g-util.boot ) + ${TANGLE} ${IN}/g-util.lisp.pamphlet >g-util.lisp ) @ -<>= -${DOC}/g-util.boot.dvi: ${IN}/g-util.boot.pamphlet - @echo 275 making ${DOC}/g-util.boot.dvi from ${IN}/g-util.boot.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/g-util.boot.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} g-util.boot ; \ - rm -f ${DOC}/g-util.boot.pamphlet ; \ - rm -f ${DOC}/g-util.boot.tex ; \ - rm -f ${DOC}/g-util.boot ) +<>= +${OUT}/g-util.lisp: ${IN}/g-util.lisp.pamphlet + @ echo 221 making ${OUT}/g-util.lisp from ${IN}/g-util.boot.pamphlet + @ rm -f ${OUT}/g-util.${O} + @( cd ${OUT} ; \ + ${TANGLE} ${IN}/g-util.lisp.pamphlet >g-util.lisp ) @ @@ -6658,8 +6630,7 @@ clean: <> <> -<> -<> +<> <> <> diff --git a/src/interp/g-util.boot.pamphlet b/src/interp/g-util.boot.pamphlet deleted file mode 100644 index dd1e8c4..0000000 --- a/src/interp/g-util.boot.pamphlet +++ /dev/null @@ -1,1702 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp g-util.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -This file contains both the {\bf boot} code and the {\bf Lisp} -code that is the result of the {\bf boot to lisp} translation. -We need to keep the translated code around so we can bootstrap -the system. In other words, we need this boot code translated -so we can build the boot translator. - -{\bf NOTE WELL: IF YOU CHANGE THIS BOOT CODE YOU MUST TRANSLATE -THIS CODE TO LISP AND STORE THE RESULTING LISP CODE BACK INTO -THIS FILE.} - -See the {\bf g-util.clisp} section below. - -\section{Utility Functions of General Use} -\subsection{PPtoFile} -<<*>>= -PPtoFile(x, fname) == - stream := DEFIOSTREAM([['MODE, :'OUTPUT], ['FILE, :fname]], 80, 0) - PRETTYPRINT(x, stream) - SHUT stream - x - -@ -\subsection{bool} -Convert an arbitrary lisp object to canonical boolean. -<<*>>= -bool x == - NULL NULL x - -@ -\subsection{Identity} -<<*>>= -Identity x == x - -@ -\section{Property Lists} -\subsection{length1?} -<<*>>= -length1? l == PAIRP l and not PAIRP QCDR l - -@ -\subsection{length2?} -<<*>>= -length2? l == PAIRP l and PAIRP (l := QCDR l) and not PAIRP QCDR l - -@ -\subsection{pairList} -<<*>>= -pairList(u,v) == [[x,:y] for x in u for y in v] - -@ -\subsection{GETALIST} -<<*>>= -GETALIST(alist,prop) == CDR assoc(prop,alist) - -@ -\subsection{PUTALIST} -<<*>>= -PUTALIST(alist,prop,val) == - null alist => [[prop,:val]] - pair := assoc(prop,alist) => - CDR pair = val => alist - -- else we fall over Lucid's read-only storage feature again - QRPLACD(pair,val) - alist - QRPLACD(LASTPAIR alist,[[prop,:val]]) - alist - -@ -\subsection{REMALIST} -<<*>>= -REMALIST(alist,prop) == - null alist => alist - alist is [[ =prop,:.],:r] => - null r => NIL - QRPLACA(alist,CAR r) - QRPLACD(alist,CDR r) - alist - null rest alist => alist - l := alist - ok := true - while ok repeat - [.,[p,:.],:r] := l - p = prop => - ok := NIL - QRPLACD(l,r) - if null (l := QCDR l) or null rest l then ok := NIL - alist - -@ -\section{Association Lists} -\subsection{deleteLassoc} -<<*>>= -deleteLassoc(x,y) == - y is [[a,:.],:y'] => - EQ(x,a) => y' - [first y,:deleteLassoc(x,y')] - y - -@ -\subsection{deleteAssoc} -<<*>>= -deleteAssoc(x,y) == - y is [[a,:.],:y'] => - a=x => deleteAssoc(x,y') - [first y,:deleteAssoc(x,y')] - y - -@ -\subsection{deleteAssocWOC} -<<*>>= -deleteAssocWOC(x,y) == - null y => y - [[a,:.],:t]:= y - x=a => t - (fn(x,y);y) where fn(x,y is [h,:t]) == - t is [[a,:.],:t1] => - x=a => RPLACD(y,t1) - fn(x,t) - nil - -@ -\subsection{insertWOC} -<<*>>= -insertWOC(x,y) == - null y => [x] - (fn(x,y); y) where fn(x,y is [h,:t]) == - x=h => nil - null t => - RPLACD(y,[h,:t]) - RPLACA(y,x) - fn(x,t) - -@ -\section{String Handling} -\subsection{fillerSpaces} -<<*>>= -fillerSpaces(n,:charPart) == - n <= 0 => '"" - MAKE_-FULL_-CVEC(n,IFCAR charPart or '" ") - -@ -\subsection{centerString} -<<*>>= -centerString(text,width,fillchar) == - wid := entryWidth text - wid >= width => text - f := DIVIDE(width - wid,2) - fill1 := "" - for i in 1..(f.0) repeat - fill1 := STRCONC(fillchar,fill1) - fill2:= fill1 - if f.1 ^= 0 then fill1 := STRCONC(fillchar,fill1) - [fill1,text,fill2] - -@ -\subsection{stringPrefix?} -<<*>>= -stringPrefix?(pref,str) == - -- sees if the first #pref letters of str are pref - -- replaces STRINGPREFIXP - null (STRINGP(pref) and STRINGP(str)) => NIL - (lp := QCSIZE pref) = 0 => true - lp > QCSIZE str => NIL - ok := true - i := 0 - while ok and (i < lp) repeat - not EQ(SCHAR(pref,i),SCHAR(str,i)) => ok := NIL - i := i + 1 - ok - -@ -\subsection{stringChar2Integer} -<<*>>= -stringChar2Integer(str,pos) == - -- replaces GETSTRINGDIGIT in UT LISP - -- returns small integer represented by character in position pos - -- in string str. Returns NIL if not a digit or other error. - if IDENTP str then str := PNAME str - null (STRINGP(str) and - INTEGERP(pos) and (pos >= 0) and (pos < QCSIZE(str))) => NIL - not DIGITP(d := SCHAR(str,pos)) => NIL - DIG2FIX d - -@ -\subsection{dropLeadingBlanks} -<<*>>= -dropLeadingBlanks str == - str := object2String str - l := QCSIZE str - nb := NIL - i := 0 - while (i < l) and not nb repeat - if SCHAR(str,i) ^= " " then nb := i - else i := i + 1 - nb = 0 => str - nb => SUBSTRING(str,nb,NIL) - '"" - -@ -\subsection{concat} -<<*>>= -concat(:l) == concatList l - -@ -\subsection{concatList} -<<*>>= -concatList [x,:y] == - null y => x - null x => concatList y - concat1(x,concatList y) - -@ -\subsection{concat1} -<<*>>= -concat1(x,y) == - null x => y - atom x => (null y => x; atom y => [x,y]; [x,:y]) - null y => x - atom y => [:x,y] - [:x,:y] - -@ -\section{BOOT ravel and reshape} -\subsection{ravel} -<<*>>= -ravel a == a - -@ -\subsection{reshape} -<<*>>= -reshape(a,b) == a - -@ -\section{Some functions for algebra code} -\subsection{boolODDP} -<<*>>= -boolODDP x == ODDP x - -@ -\section{Miscellaneous} -\subsection{freeOfSharpVars} -<<*>>= -freeOfSharpVars x == - atom x => not isSharpVarWithNum x - freeOfSharpVars first x and freeOfSharpVars rest x - -@ -\subsection{listOfSharpVars} -<<*>>= -listOfSharpVars x == - atom x => (isSharpVarWithNum x => LIST x; nil) - setUnion(listOfSharpVars first x,listOfSharpVars rest x) - -@ -\subsection{listOfPatternIds} -<<*>>= -listOfPatternIds x == - isPatternVar x => [x] - atom x => nil - x is ['QUOTE,:.] => nil - UNIONQ(listOfPatternIds first x,listOfPatternIds rest x) - -@ -\subsection{isPatternVar} -<<*>>= -isPatternVar v == - -- a pattern variable consists of a star followed by a star or digit(s) - IDENTP(v) and MEMQ(v,'(_*_* _*1 _*2 _*3 _*4 _*5 _*6 _*7 _*8 _*9 _*10 - _*11 _*12 _*13 _*14 _*15 _*16 _*17 _*18 _*19 _*20)) and true - -@ -\subsection{removeZeroOne} -<<*>>= -removeZeroOne x == - -- replace all occurrences of (Zero) and (One) with - -- 0 and 1 - x = $Zero => 0 - x = $One => 1 - atom x => x - [removeZeroOne first x,:removeZeroOne rest x] - -@ -\subsection{removeZeroOneDestructively} -<<*>>= -removeZeroOneDestructively t == - -- replace all occurrences of (Zero) and (One) with - -- 0 and 1 destructively - t = $Zero => 0 - t = $One => 1 - atom t => t - RPLNODE(t,removeZeroOneDestructively first t, - removeZeroOneDestructively rest t) - -@ -\subsection{flattenSexpr} -<<*>>= -flattenSexpr s == - null s => s - ATOM s => s - [f,:r] := s - ATOM f => [f,:flattenSexpr r] - [:flattenSexpr f,:flattenSexpr r] - -@ -\subsection{isLowerCaseLetter} -<<*>>= -isLowerCaseLetter c == charRangeTest CHAR2NUM c - -@ -\subsection{isUpperCaseLetter} -<<*>>= -isUpperCaseLetter c == charRangeTest QSDIFFERENCE(CHAR2NUM c,64) - -@ -\subsection{isLetter} -<<*>>= -isLetter c == - n:= CHAR2NUM c - charRangeTest n or charRangeTest QSDIFFERENCE(CHAR2NUM c,64) - -@ -\subsection{charRangeTest} -<<*>>= -charRangeTest n == - QSLESSP(153,n) => - QSLESSP(169,n) => false - QSLESSP(161,n) => true - false - QSLESSP(128,n) => - QSLESSP(144,n) => true - QSLESSP(138,n) => false - true - false - -@ -\subsection{update} -<<*>>= -update() == - OBEY - STRCONC('"SPADEDIT ",STRINGIMAGE _/VERSION,'" ",STRINGIMAGE _/WSNAME,'" A") - _/UPDATE() - -@ -\section{Inplace Merge Sort for Lists} -MBM April/88 - -\verb|listSort(pred,list)| or \verb|listSort(pred,list,key)| -The pred function is a boolean valued function defining the ordering -the key function extracts the key from an item for comparison by pred - -\subsection{listSort} -<<*>>= -listSort(pred,list,:optional) == - NOT functionp pred => error "listSort: first arg must be a function" - NOT LISTP list => error "listSort: second argument must be a list" - NULL optional => mergeSort(pred,function Identity,list,LENGTH list) - key := CAR optional - NOT functionp key => error "listSort: last arg must be a function" - mergeSort(pred,key,list,LENGTH list) - -@ -\subsection{MSORT} -Non-destructive merge sort using NOT GGREATERP as predicate -<<*>>= -MSORT list == listSort(function GLESSEQP, COPY_-LIST list) - -@ -\subsection{NMSORT} -Destructive merge sort using NOT GGREATERP as predicate -<<*>>= -NMSORT list == listSort(function GLESSEQP, list) - -@ -\subsection{orderList} -Non-destructive merge sort using ?ORDER as predicate -<<*>>= -orderList l == listSort(function _?ORDER, COPY_-LIST l) - -@ -\subsection{mergeInPlace} -Merge the two sorted lists p and q -<<*>>= -mergeInPlace(f,g,p,q) == - if NULL p then return p - if NULL q then return q - if FUNCALL(f,FUNCALL(g, QCAR p),FUNCALL(g, QCAR q)) - then (r := t := p; p := QCDR p) - else (r := t := q; q := QCDR q) - while not NULL p and not NULL q repeat - if FUNCALL(f,FUNCALL(g,QCAR p),FUNCALL(g,QCAR q)) - then (QRPLACD(t,p); t := p; p := QCDR p) - else (QRPLACD(t,q); t := q; q := QCDR q) - if NULL p then QRPLACD(t,q) else QRPLACD(t,p) - r - -@ -\subsection{mergeSort} -<<*>>= -mergeSort(f,g,p,n) == - if EQ(n,2) and FUNCALL(f,FUNCALL(g,QCADR p),FUNCALL(g,QCAR p)) then - t := p - p := QCDR p - QRPLACD(p,t) - QRPLACD(t,NIL) - if QSLESSP(n,3) then return p - -- split the list p into p and q of equal length - l := QSQUOTIENT(n,2) - t := p - for i in 1..l-1 repeat t := QCDR t - q := rest t - QRPLACD(t,NIL) - p := mergeSort(f,g,p,l) - q := mergeSort(f,g,q,QSDIFFERENCE(n,l)) - mergeInPlace(f,g,p,q) - -@ -\subsection{spadThrow} -Throwing with glorious highlighting (maybe) -<<*>>= -spadThrow() == - if $interpOnly and $mapName then - putHist($mapName,'localModemap, nil, $e) - THROW("SPAD__READER",nil) - -@ -\subsection{spadThrowBrightly} -<<*>>= -spadThrowBrightly x == - sayBrightly x - spadThrow() - -@ -\subsection{formatUnabbreviatedSig} -Type Formatting Without Abbreviation -<<*>>= -formatUnabbreviatedSig sig == - null sig => ["() -> ()"] - [target,:args] := sig - target := formatUnabbreviated target - null args => ['"() -> ",:target] - null rest args => [:formatUnabbreviated QCAR args,'" -> ",:target] - args := formatUnabbreviatedTuple args - ['"(",:args,'") -> ",:target] - -@ -\subsection{formatUnabbreviatedTuple} -<<*>>= -formatUnabbreviatedTuple t == - -- t is a list of types - null t => t - atom t => [t] - t0 := formatUnabbreviated QCAR t - null rest t => t0 - [:t0,'",",:formatUnabbreviatedTuple QCDR t] - -@ -\subsection{formatUnabbreviated} -<<*>>= -formatUnabbreviated t == - atom t => - [t] - null t => - ['"()"] - t is [p,sel,arg] and p in '(_: ":") => - [sel,'": ",:formatUnabbreviated arg] - t is ['Union,:args] => - ['Union,'"(",:formatUnabbreviatedTuple args,'")"] - t is ['Mapping,:args] => - formatUnabbreviatedSig args - t is ['Record,:args] => - ['Record,'"(",:formatUnabbreviatedTuple args,'")"] - t is [arg] => - t - t is [arg,arg1] => - [arg,'" ",:formatUnabbreviated arg1] - t is [arg,:args] => - [arg,'"(",:formatUnabbreviatedTuple args,'")"] - t - -@ -\subsection{sublisNQ} -<<*>>= -sublisNQ(al,e) == - atom al => e - fn(al,e) where fn(al,e) == - atom e => - for x in al repeat - EQ(first x,e) => return (e := rest x) - e - EQ(a := first e,'QUOTE) => e - u := fn(al,a) - v := fn(al,rest e) - EQ(a,u) and EQ(rest e,v) => e - [u,:v] - -@ -\subsection{str2Outform} -Function for turning strings in tex format -<<*>>= -str2Outform s == - parse := ncParseFromString s or systemError '"String for TeX will not parse" - parse2Outform parse - -@ -\subsection{parse2Outform} -<<*>>= -parse2Outform x == - x is [op,:argl] => - nargl := [parse2Outform y for y in argl] - op = 'construct => ['BRACKET,['ARGLST,:[parse2Outform y for y in argl]]] - op = 'brace and nargl is [[BRACKET,:r]] => ['BRACE,:r] - [op,:nargl] - x - -@ -\subsection{str2Tex} -<<*>>= -str2Tex s == - outf := str2Outform s - val := coerceInt(mkObj(wrap outf, '(OutputForm)), '(TexFormat)) - val := objValUnwrap val - CAR val.1 - -@ -\subsection{opOf} -<<*>>= -opOf x == - atom x => x - first x - -@ -\subsection{getProplist} -<<*>>= -getProplist(x,E) == - not atom x => getProplist(first x,E) - u:= search(x,E) => u - --$InteractiveMode => nil - --$InteractiveMode and (u:= search(x,$InteractiveFrame)) => u - (pl:=search(x,$CategoryFrame)) => - pl --- (pl:=PROPLIST x) => pl --- Above line commented out JHD/BMT 2.Aug.90 - -@ -\subsection{search} -<<*>>= -search(x,e is [curEnv,:tailEnv]) == - searchCurrentEnv(x,curEnv) or searchTailEnv(x,tailEnv) - -@ -\subsection{searchCurrentEnv} -<<*>>= -searchCurrentEnv(x,currentEnv) == - for contour in currentEnv repeat - if u:= ASSQ(x,contour) then return (signal:= u) - KDR signal - -@ -\subsection{searchTailEnv} -<<*>>= -searchTailEnv(x,e) == - for env in e repeat - signal:= - for contour in env repeat - if (u:= ASSQ(x,contour)) and ASSQ("FLUID",u) then return (signal:= u) - if signal then return signal - KDR signal - -@ -\subsection{augProplist} -<<*>>= -augProplist(proplist,prop,val) == - $InteractiveMode => augProplistInteractive(proplist,prop,val) - while (proplist is [[ =prop,:.],:proplist']) repeat proplist:= proplist' - val=(u:= LASSOC(prop,proplist)) => proplist - null val => - null u => proplist - DELLASOS(prop,proplist) - [[prop,:val],:proplist] - -@ -\subsection{augProplistOf} -<<*>>= -augProplistOf(var,prop,val,e) == - proplist:= getProplist(var,e) - semchkProplist(var,proplist,prop,val) - augProplist(proplist,prop,val) - -@ -\subsection{semchkProplist} -<<*>>= -semchkProplist(x,proplist,prop,val) == - prop="isLiteral" => - LASSOC("value",proplist) or LASSOC("mode",proplist) => warnLiteral x - MEMQ(prop,'(mode value)) => - LASSOC("isLiteral",proplist) => warnLiteral x - -@ -\subsection{addBinding} -The \verb|$envHashTable| is a performance improvement by Waldek Hebisch. -<<*>>= -DEFPARAMETER($envHashTable,nil) - -addBinding(var,proplist,e is [[curContour,:tailContour],:tailEnv]) == - EQ(proplist,getProplist(var,e)) => e - if $envHashTable then - for u in proplist repeat - HPUT($envHashTable,[var, CAR u],true) - $InteractiveMode => addBindingInteractive(var,proplist,e) - if curContour is [[ =var,:.],:.] then curContour:= rest curContour - --Previous line should save some space - [[[lx,:curContour],:tailContour],:tailEnv] where lx:= [var,:proplist] - -@ -\subsection{position} -<<*>>= -position(x,l) == - posn(x,l,0) where - posn(x,l,n) == - null l => -1 - x=first l => n - posn(x,rest l,n+1) - -@ -\subsection{insert} -<<*>>= -insert(x,y) == - MEMBER(x,y) => y - [x,:y] - -@ -\subsection{after} -<<*>>= -after(u,v) == - r:= u - for x in u for y in v repeat r:= rest r - r - -@ -\section{String trimming} -<<*>>= -$blank := char ('_ ) - -@ -\subsection{trimString} -<<*>>= -trimString s == - leftTrim rightTrim s - -@ -\subsection{leftTrim} -<<*>>= -leftTrim s == - k := MAXINDEX s - k < 0 => s - s.0 = $blank => - for i in 0..k while s.i = $blank repeat (j := i) - SUBSTRING(s,j + 1,nil) - s - -@ -\subsection{rightTrim} -<<*>>= -rightTrim s == -- assumed a non-empty string - k := MAXINDEX s - k < 0 => s - s.k = $blank => - for i in k..0 by -1 while s.i = $blank repeat (j := i) - SUBSTRING(s,0,j) - s - -@ -\subsection{pp} -<<*>>= -pp x == - PRETTYPRINT x - x - -@ -\subsection{pr} -<<*>>= -pr x == - F_,PRINT_-ONE x - nil - -@ -\subsection{quickAnd} -<<*>>= -quickAnd(a,b) == - a = true => b - b = true => a - a = false or b = false => false - simpBool ['AND,a,b] - -@ -\subsection{quickOr} -<<*>>= -quickOr(a,b) == - a = true or b = true => true - b = false => a - a = false => b - simpCatPredicate simpBool ['OR,a,b] - -@ -\subsection{intern} -<<*>>= -intern x == - STRINGP x => - DIGITP x.0 => string2Integer x - INTERN x - x - -@ -\subsection{isDomain} -<<*>>= -isDomain a == - PAIRP a and VECP(CAR a) and - MEMBER(CAR(a).0, $domainTypeTokens) - -@ -\section{Variables used by browser} -<<*>>= -$htHash := MAKE_-HASH_-TABLE() -$glossHash := MAKE_-HASH_-TABLE() -$lispHash := MAKE_-HASH_-TABLE() -$sysHash := MAKE_-HASH_-TABLE() -$htSystemCommands := '( - (boot . development) clear display (fin . development) edit help - frame history load quit read set show synonym system - trace what ) -$currentSysList := [opOf x for x in $htSystemCommands] --see ht-root -$outStream := nil -$recheckingFlag := false --see transformAndRecheckComments -$exposeFlag := false --if true, messages go to $outStream -$exposeFlagHeading := false --see htcheck.boot -$checkingXmptex? := false --see htcheck.boot -$exposeDocHeading:= nil --see htcheck.boot -$charPlus := char '_+ -$charBlank:= (char '_ ) -$charLbrace:= char '_{ -$charRbrace:= char '_} -$charBack := char '_\ -$charDash := char '_- - -$charTab := CODE_-CHAR(9) -$charNewline := CODE_-CHAR(10) -$charFauxNewline := CODE_-CHAR(25) -$stringNewline := PNAME CODE_-CHAR(10) -$stringFauxNewline := PNAME CODE_-CHAR(25) - -$charExclusions := [char 'a, char 'A] -$charQuote := char '_' -$charSemiColon := char '_; -$charComma := char '_, -$charPeriod := char '_. -$checkPrenAlist := [[char '_(,:char '_)],[char '_{,:char '_}],[char '_[,:char '_]]] -$charEscapeList:= [char '_%,char '_#,$charBack] -$charIdentifierEndings := [char '__, char '_!, char '_?] -$charSplitList := [$charComma,$charPeriod,char '_[, char '_],$charLbrace, $charRbrace, char '_(, char '_), char '_$, char '_%] -$charDelimiters := [$charBlank, char '_(, char '_), $charBack] -$HTspadmacros := '("\spadtype" "\spadcommand" "\spadop" "\spadfun" "\spadatt" "\spadsyscom" "\spad" "\s") -$HTmacs := [ - ['"\beginmenu",$charRbrace,'"menu",$charLbrace,'"\begin"], - ['"\endmenu",$charRbrace,'"menu",$charLbrace,'"\end"], - ['"\beginitems",$charRbrace,'"items",$charLbrace,'"\begin"], - ['"\enditems",$charRbrace,'"items",$charLbrace,'"\end"], - ['"\beginscroll",$charRbrace,'"scroll",$charLbrace,'"\begin"], - ['"\endscroll",$charRbrace,'"scroll",$charLbrace,'"\end"]] - -$HTlinks := '( - "\downlink" - "\menulink" - "\menudownlink" - "\menuwindowlink" - "\menumemolink") - -$HTlisplinks := '( - "\lispdownlink" - "\menulispdownlink" - "\menulispwindowlink" - "\menulispmemolink" - "\lispwindowlink" - "\lispmemolink") - -$beginEndList := '( - "page" - "items" - "menu" - "scroll" - "verbatim" - "detail") - -@ -\subsection{isDefaultPackageName} -<<*>>= -isDefaultPackageName x == (s := PNAME x).(MAXINDEX s) = char '_& -@ -\section{g-util.clisp} -<>= -;;; -*- Mode:Lisp; Package:Boot -*- - - -(IN-PACKAGE "BOOT" ) - -;PPtoFile(x, fname) == -; stream := DEFIOSTREAM([['MODE, :'OUTPUT], ['FILE, :fname]], 80, 0) -; PRETTYPRINT(x, stream) -; SHUT stream -; x - -;;; *** |PPtoFile| REDEFINED - -(DEFUN |PPtoFile| (|x| |fname|) (PROG (|stream|) (RETURN (PROGN (SPADLET |stream| (DEFIOSTREAM (CONS (CONS (QUOTE MODE) (QUOTE OUTPUT)) (CONS (CONS (QUOTE FILE) |fname|) NIL)) 80 0)) (PRETTYPRINT |x| |stream|) (SHUT |stream|) |x|)))) -;bool x == -; NULL NULL x - -;;; *** |bool| REDEFINED - -(DEFUN |bool| (|x|) (NULL (NULL |x|))) -;Identity x == x - -;;; *** |Identity| REDEFINED - -(DEFUN |Identity| (|x|) |x|) -;length1? l == PAIRP l and not PAIRP QCDR l - -;;; *** |length1?| REDEFINED - -(DEFUN |length1?| (|l|) (AND (PAIRP |l|) (NULL (PAIRP (QCDR |l|))))) -;length2? l == PAIRP l and PAIRP (l := QCDR l) and not PAIRP QCDR l - -;;; *** |length2?| REDEFINED - -(DEFUN |length2?| (|l|) (AND (PAIRP |l|) (PAIRP (SPADLET |l| (QCDR |l|))) (NULL (PAIRP (QCDR |l|))))) -;pairList(u,v) == [[x,:y] for x in u for y in v] - -;;; *** |pairList| REDEFINED - -(DEFUN |pairList| (|u| |v|) (PROG NIL (RETURN (SEQ (PROG (#0=#:G1403) (SPADLET #0# NIL) (RETURN (DO ((#1=#:G1404 |u| (CDR #1#)) (|x| NIL) (#2=#:G1405 |v| (CDR #2#)) (|y| NIL)) ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL) (ATOM #2#) (PROGN (SETQ |y| (CAR #2#)) NIL)) (NREVERSE0 #0#)) (SEQ (EXIT (SETQ #0# (CONS (CONS |x| |y|) #0#))))))))))) -;GETALIST(alist,prop) == CDR assoc(prop,alist) - -;;; *** GETALIST REDEFINED - -(DEFUN GETALIST (|alist| |prop|) (CDR (|assoc| |prop| |alist|))) -;PUTALIST(alist,prop,val) == -; null alist => [[prop,:val]] -; pair := assoc(prop,alist) => -; CDR pair = val => alist -; -- else we fall over Lucid's read-only storage feature again -; QRPLACD(pair,val) -; alist -; QRPLACD(LASTPAIR alist,[[prop,:val]]) -; alist - -;;; *** PUTALIST REDEFINED - -(DEFUN PUTALIST (|alist| |prop| |val|) (PROG (|pair|) (RETURN (COND ((NULL |alist|) (CONS (CONS |prop| |val|) NIL)) ((SPADLET |pair| (|assoc| |prop| |alist|)) (COND ((BOOT-EQUAL (CDR |pair|) |val|) |alist|) ((QUOTE T) (QRPLACD |pair| |val|) |alist|))) ((QUOTE T) (QRPLACD (LASTPAIR |alist|) (CONS (CONS |prop| |val|) NIL)) |alist|))))) -;REMALIST(alist,prop) == -; null alist => alist -; alist is [[ =prop,:.],:r] => -; null r => NIL -; QRPLACA(alist,CAR r) -; QRPLACD(alist,CDR r) -; alist -; null rest alist => alist -; l := alist -; ok := true -; while ok repeat -; [.,[p,:.],:r] := l -; p = prop => -; ok := NIL -; QRPLACD(l,r) -; if null (l := QCDR l) or null rest l then ok := NIL -; alist - -;;; *** REMALIST REDEFINED - -(DEFUN REMALIST (|alist| |prop|) (PROG (|ISTMP#1| |p| |r| |l| |ok|) (RETURN (SEQ (COND ((NULL |alist|) |alist|) ((AND (PAIRP |alist|) (PROGN (SPADLET |ISTMP#1| (QCAR |alist|)) (AND (PAIRP |ISTMP#1|) (EQUAL (QCAR |ISTMP#1|) |prop|))) (PROGN (SPADLET |r| (QCDR |alist|)) (QUOTE T))) (COND ((NULL |r|) NIL) ((QUOTE T) (QRPLACA |alist| (CAR |r|)) (QRPLACD |alist| (CDR |r|)) |alist|))) ((NULL (CDR |alist|)) |alist|) ((QUOTE T) (SPADLET |l| |alist|) (SPADLET |ok| (QUOTE T)) (DO NIL ((NULL |ok|) NIL) (SEQ (EXIT (PROGN (SPADLET |p| (CAADR |l|)) (SPADLET |r| (CDDR |l|)) (COND ((BOOT-EQUAL |p| |prop|) (SPADLET |ok| NIL) (QRPLACD |l| |r|)) ((OR (NULL (SPADLET |l| (QCDR |l|))) (NULL (CDR |l|))) (SPADLET |ok| NIL)) ((QUOTE T) NIL)))))) |alist|)))))) -;deleteLassoc(x,y) == -; y is [[a,:.],:y'] => -; EQ(x,a) => y' -; [first y,:deleteLassoc(x,y')] -; y - -;;; *** |deleteLassoc| REDEFINED - -(DEFUN |deleteLassoc| (|x| |y|) (PROG (|ISTMP#1| |a| |y'|) (RETURN (COND ((AND (PAIRP |y|) (PROGN (SPADLET |ISTMP#1| (QCAR |y|)) (AND (PAIRP |ISTMP#1|) (PROGN (SPADLET |a| (QCAR |ISTMP#1|)) (QUOTE T)))) (PROGN (SPADLET |y'| (QCDR |y|)) (QUOTE T))) (COND ((EQ |x| |a|) |y'|) ((QUOTE T) (CONS (CAR |y|) (|deleteLassoc| |x| |y'|))))) ((QUOTE T) |y|))))) -;deleteAssoc(x,y) == -; y is [[a,:.],:y'] => -; a=x => deleteAssoc(x,y') -; [first y,:deleteAssoc(x,y')] -; y - -;;; *** |deleteAssoc| REDEFINED - -(DEFUN |deleteAssoc| (|x| |y|) (PROG (|ISTMP#1| |a| |y'|) (RETURN (COND ((AND (PAIRP |y|) (PROGN (SPADLET |ISTMP#1| (QCAR |y|)) (AND (PAIRP |ISTMP#1|) (PROGN (SPADLET |a| (QCAR |ISTMP#1|)) (QUOTE T)))) (PROGN (SPADLET |y'| (QCDR |y|)) (QUOTE T))) (COND ((BOOT-EQUAL |a| |x|) (|deleteAssoc| |x| |y'|)) ((QUOTE T) (CONS (CAR |y|) (|deleteAssoc| |x| |y'|))))) ((QUOTE T) |y|))))) -;deleteAssocWOC(x,y) == -; null y => y -; [[a,:.],:t]:= y -; x=a => t -; (fn(x,y);y) where fn(x,y is [h,:t]) == -; t is [[a,:.],:t1] => -; x=a => RPLACD(y,t1) -; fn(x,t) -; nil - -;;; *** |deleteAssocWOC,fn| REDEFINED - -(DEFUN |deleteAssocWOC,fn| (|x| |y|) (PROG (|h| |t| |ISTMP#1| |a| |t1|) (RETURN (SEQ (PROGN (SPADLET |h| (CAR |y|)) (SPADLET |t| (CDR |y|)) |y| (SEQ (IF (AND (PAIRP |t|) (PROGN (SPADLET |ISTMP#1| (QCAR |t|)) (AND (PAIRP |ISTMP#1|) (PROGN (SPADLET |a| (QCAR |ISTMP#1|)) (QUOTE T)))) (PROGN (SPADLET |t1| (QCDR |t|)) (QUOTE T))) (EXIT (SEQ (IF (BOOT-EQUAL |x| |a|) (EXIT (RPLACD |y| |t1|))) (EXIT (|deleteAssocWOC,fn| |x| |t|))))) (EXIT NIL))))))) - -;;; *** |deleteAssocWOC| REDEFINED - -(DEFUN |deleteAssocWOC| (|x| |y|) (PROG (|a| |t|) (RETURN (COND ((NULL |y|) |y|) ((QUOTE T) (SPADLET |a| (CAAR |y|)) (SPADLET |t| (CDR |y|)) (COND ((BOOT-EQUAL |x| |a|) |t|) ((QUOTE T) (|deleteAssocWOC,fn| |x| |y|) |y|))))))) -;insertWOC(x,y) == -; null y => [x] -; (fn(x,y); y) where fn(x,y is [h,:t]) == -; x=h => nil -; null t => -; RPLACD(y,[h,:t]) -; RPLACA(y,x) -; fn(x,t) - -;;; *** |insertWOC,fn| REDEFINED - -(DEFUN |insertWOC,fn| (|x| |y|) (PROG (|h| |t|) (RETURN (SEQ (PROGN (SPADLET |h| (CAR |y|)) (SPADLET |t| (CDR |y|)) |y| (SEQ (IF (BOOT-EQUAL |x| |h|) (EXIT NIL)) (IF (NULL |t|) (EXIT (SEQ (RPLACD |y| (CONS |h| |t|)) (EXIT (RPLACA |y| |x|))))) (EXIT (|insertWOC,fn| |x| |t|)))))))) - -;;; *** |insertWOC| REDEFINED - -(DEFUN |insertWOC| (|x| |y|) (COND ((NULL |y|) (CONS |x| NIL)) ((QUOTE T) (|insertWOC,fn| |x| |y|) |y|))) -;fillerSpaces(n,:charPart) == -; n <= 0 => '"" -; MAKE_-FULL_-CVEC(n,IFCAR charPart or '" ") - -;;; *** |fillerSpaces| REDEFINED - -(DEFUN |fillerSpaces| (&REST #0=#:G1406 &AUX |charPart| |n|) (DSETQ (|n| . |charPart|) #0#) (COND ((<= |n| 0) (MAKESTRING "")) ((QUOTE T) (MAKE-FULL-CVEC |n| (OR (IFCAR |charPart|) (MAKESTRING " ")))))) -;centerString(text,width,fillchar) == -; wid := entryWidth text -; wid >= width => text -; f := DIVIDE(width - wid,2) -; fill1 := "" -; for i in 1..(f.0) repeat -; fill1 := STRCONC(fillchar,fill1) -; fill2:= fill1 -; if f.1 ^= 0 then fill1 := STRCONC(fillchar,fill1) -; [fill1,text,fill2] - -;;; *** |centerString| REDEFINED - -(DEFUN |centerString| (|text| |width| |fillchar|) (PROG (|wid| |f| |fill2| |fill1|) (RETURN (SEQ (PROGN (SPADLET |wid| (|entryWidth| |text|)) (COND ((>= |wid| |width|) |text|) ((QUOTE T) (SPADLET |f| (DIVIDE (SPADDIFFERENCE |width| |wid|) 2)) (SPADLET |fill1| (QUOTE ||)) (DO ((#0=#:G1407 (ELT |f| 0)) (|i| 1 (QSADD1 |i|))) ((QSGREATERP |i| #0#) NIL) (SEQ (EXIT (SPADLET |fill1| (STRCONC |fillchar| |fill1|))))) (SPADLET |fill2| |fill1|) (COND ((NEQUAL (ELT |f| 1) 0) (SPADLET |fill1| (STRCONC |fillchar| |fill1|)))) (CONS |fill1| (CONS |text| (CONS |fill2| NIL)))))))))) -;stringPrefix?(pref,str) == -; -- sees if the first #pref letters of str are pref -; -- replaces STRINGPREFIXP -; null (STRINGP(pref) and STRINGP(str)) => NIL -; (lp := QCSIZE pref) = 0 => true -; lp > QCSIZE str => NIL -; ok := true -; i := 0 -; while ok and (i < lp) repeat -; not EQ(SCHAR(pref,i),SCHAR(str,i)) => ok := NIL -; i := i + 1 -; ok - -;;; *** |stringPrefix?| REDEFINED - -(DEFUN |stringPrefix?| (|pref| |str|) (PROG (|lp| |ok| |i|) (RETURN (SEQ (COND ((NULL (AND (STRINGP |pref|) (STRINGP |str|))) NIL) ((EQL (SPADLET |lp| (QCSIZE |pref|)) 0) (QUOTE T)) ((> |lp| (QCSIZE |str|)) NIL) ((QUOTE T) (SPADLET |ok| (QUOTE T)) (SPADLET |i| 0) (DO NIL ((NULL (AND |ok| (> |lp| |i|))) NIL) (SEQ (EXIT (COND ((NULL (EQ (SCHAR |pref| |i|) (SCHAR |str| |i|))) (SPADLET |ok| NIL)) ((QUOTE T) (SPADLET |i| (PLUS |i| 1))))))) |ok|)))))) -;stringChar2Integer(str,pos) == -; -- replaces GETSTRINGDIGIT in UT LISP -; -- returns small integer represented by character in position pos -; -- in string str. Returns NIL if not a digit or other error. -; if IDENTP str then str := PNAME str -; null (STRINGP(str) and -; INTEGERP(pos) and (pos >= 0) and (pos < QCSIZE(str))) => NIL -; not DIGITP(d := SCHAR(str,pos)) => NIL -; DIG2FIX d - -;;; *** |stringChar2Integer| REDEFINED - -(DEFUN |stringChar2Integer| (|str| |pos|) (PROG (|d|) (RETURN (PROGN (COND ((IDENTP |str|) (SPADLET |str| (PNAME |str|)))) (COND ((NULL (AND (STRINGP |str|) (INTEGERP |pos|) (>= |pos| 0) (> (QCSIZE |str|) |pos|))) NIL) ((NULL (DIGITP (SPADLET |d| (SCHAR |str| |pos|)))) NIL) ((QUOTE T) (DIG2FIX |d|))))))) -;dropLeadingBlanks str == -; str := object2String str -; l := QCSIZE str -; nb := NIL -; i := 0 -; while (i < l) and not nb repeat -; if SCHAR(str,i) ^= " " then nb := i -; else i := i + 1 -; nb = 0 => str -; nb => SUBSTRING(str,nb,NIL) -; '"" - -;;; *** |dropLeadingBlanks| REDEFINED - -(DEFUN |dropLeadingBlanks| (|str|) (PROG (|l| |nb| |i|) (RETURN (SEQ (PROGN (SPADLET |str| (|object2String| |str|)) (SPADLET |l| (QCSIZE |str|)) (SPADLET |nb| NIL) (SPADLET |i| 0) (DO NIL ((NULL (AND (> |l| |i|) (NULL |nb|))) NIL) (SEQ (EXIT (COND ((NEQUAL (SCHAR |str| |i|) (QUOTE | |)) (SPADLET |nb| |i|)) ((QUOTE T) (SPADLET |i| (PLUS |i| 1))))))) (COND ((EQL |nb| 0) |str|) (|nb| (SUBSTRING |str| |nb| NIL)) ((QUOTE T) (MAKESTRING "")))))))) -;concat(:l) == concatList l - -;;; *** |concat| REDEFINED - -(DEFUN |concat| (&REST #0=#:G1408 &AUX |l|) (DSETQ |l| #0#) (|concatList| |l|)) -;concatList [x,:y] == -; null y => x -; null x => concatList y -; concat1(x,concatList y) - -;;; *** |concatList| REDEFINED - -(DEFUN |concatList| (#0=#:G1409) (PROG (|x| |y|) (RETURN (PROGN (SPADLET |x| (CAR #0#)) (SPADLET |y| (CDR #0#)) (COND ((NULL |y|) |x|) ((NULL |x|) (|concatList| |y|)) ((QUOTE T) (|concat1| |x| (|concatList| |y|)))))))) -;concat1(x,y) == -; null x => y -; atom x => (null y => x; atom y => [x,y]; [x,:y]) -; null y => x -; atom y => [:x,y] -; [:x,:y] - -;;; *** |concat1| REDEFINED - -(DEFUN |concat1| (|x| |y|) (COND ((NULL |x|) |y|) ((ATOM |x|) (COND ((NULL |y|) |x|) ((ATOM |y|) (CONS |x| (CONS |y| NIL))) ((QUOTE T) (CONS |x| |y|)))) ((NULL |y|) |x|) ((ATOM |y|) (APPEND |x| (CONS |y| NIL))) ((QUOTE T) (APPEND |x| |y|)))) -;ravel a == a - -;;; *** |ravel| REDEFINED - -(DEFUN |ravel| (|a|) |a|) -;reshape(a,b) == a - -;;; *** |reshape| REDEFINED - -(DEFUN |reshape| (|a| |b|) |a|) -;boolODDP x == ODDP x - -;;; *** |boolODDP| REDEFINED - -(DEFUN |boolODDP| (|x|) (ODDP |x|)) -;freeOfSharpVars x == -; atom x => not isSharpVarWithNum x -; freeOfSharpVars first x and freeOfSharpVars rest x - -;;; *** |freeOfSharpVars| REDEFINED - -(DEFUN |freeOfSharpVars| (|x|) (COND ((ATOM |x|) (NULL (|isSharpVarWithNum| |x|))) ((QUOTE T) (AND (|freeOfSharpVars| (CAR |x|)) (|freeOfSharpVars| (CDR |x|)))))) -;listOfSharpVars x == -; atom x => (isSharpVarWithNum x => LIST x; nil) -; setUnion(listOfSharpVars first x,listOfSharpVars rest x) - -;;; *** |listOfSharpVars| REDEFINED - -(DEFUN |listOfSharpVars| (|x|) (COND ((ATOM |x|) (COND ((|isSharpVarWithNum| |x|) (LIST |x|)) ((QUOTE T) NIL))) ((QUOTE T) (|union| (|listOfSharpVars| (CAR |x|)) (|listOfSharpVars| (CDR |x|)))))) -;listOfPatternIds x == -; isPatternVar x => [x] -; atom x => nil -; x is ['QUOTE,:.] => nil -; UNIONQ(listOfPatternIds first x,listOfPatternIds rest x) - -;;; *** |listOfPatternIds| REDEFINED - -(DEFUN |listOfPatternIds| (|x|) (COND ((|isPatternVar| |x|) (CONS |x| NIL)) ((ATOM |x|) NIL) ((AND (PAIRP |x|) (EQ (QCAR |x|) (QUOTE QUOTE))) NIL) ((QUOTE T) (UNIONQ (|listOfPatternIds| (CAR |x|)) (|listOfPatternIds| (CDR |x|)))))) -;isPatternVar v == -; -- a pattern variable consists of a star followed by a star or digit(s) -; IDENTP(v) and MEMQ(v,'(_*_* _*1 _*2 _*3 _*4 _*5 _*6 _*7 _*8 _*9 _*10 -; _*11 _*12 _*13 _*14 _*15 _*16 _*17 _*18 _*19 _*20)) and true - -;;; *** |isPatternVar| REDEFINED - -(DEFUN |isPatternVar| (|v|) (AND (IDENTP |v|) (MEMQ |v| (QUOTE (** *1 *2 *3 *4 *5 *6 *7 *8 *9 *10 *11 *12 *13 *14 *15 *16 *17 *18 *19 *20))) (QUOTE T))) -;removeZeroOne x == -; -- replace all occurrences of (Zero) and (One) with -; -- 0 and 1 -; x = $Zero => 0 -; x = $One => 1 -; atom x => x -; [removeZeroOne first x,:removeZeroOne rest x] - -;;; *** |removeZeroOne| REDEFINED - -(DEFUN |removeZeroOne| (|x|) (COND ((BOOT-EQUAL |x| |$Zero|) 0) ((BOOT-EQUAL |x| |$One|) 1) ((ATOM |x|) |x|) ((QUOTE T) (CONS (|removeZeroOne| (CAR |x|)) (|removeZeroOne| (CDR |x|)))))) -;removeZeroOneDestructively t == -; -- replace all occurrences of (Zero) and (One) with -; -- 0 and 1 destructively -; t = $Zero => 0 -; t = $One => 1 -; atom t => t -; RPLNODE(t,removeZeroOneDestructively first t, -; removeZeroOneDestructively rest t) - -;;; *** |removeZeroOneDestructively| REDEFINED - -(DEFUN |removeZeroOneDestructively| (|t|) (COND ((BOOT-EQUAL |t| |$Zero|) 0) ((BOOT-EQUAL |t| |$One|) 1) ((ATOM |t|) |t|) ((QUOTE T) (RPLNODE |t| (|removeZeroOneDestructively| (CAR |t|)) (|removeZeroOneDestructively| (CDR |t|)))))) -;flattenSexpr s == -; null s => s -; ATOM s => s -; [f,:r] := s -; ATOM f => [f,:flattenSexpr r] -; [:flattenSexpr f,:flattenSexpr r] - -;;; *** |flattenSexpr| REDEFINED - -(DEFUN |flattenSexpr| (|s|) (PROG (|f| |r|) (RETURN (COND ((NULL |s|) |s|) ((ATOM |s|) |s|) ((QUOTE T) (SPADLET |f| (CAR |s|)) (SPADLET |r| (CDR |s|)) (COND ((ATOM |f|) (CONS |f| (|flattenSexpr| |r|))) ((QUOTE T) (APPEND (|flattenSexpr| |f|) (|flattenSexpr| |r|))))))))) -;isLowerCaseLetter c == charRangeTest CHAR2NUM c - -;;; *** |isLowerCaseLetter| REDEFINED - -(DEFUN |isLowerCaseLetter| (|c|) (|charRangeTest| (CHAR2NUM |c|))) -;isUpperCaseLetter c == charRangeTest QSDIFFERENCE(CHAR2NUM c,64) - -;;; *** |isUpperCaseLetter| REDEFINED - -(DEFUN |isUpperCaseLetter| (|c|) (|charRangeTest| (QSDIFFERENCE (CHAR2NUM |c|) 64))) -;isLetter c == -; n:= CHAR2NUM c -; charRangeTest n or charRangeTest QSDIFFERENCE(CHAR2NUM c,64) - -;;; *** |isLetter| REDEFINED - -(DEFUN |isLetter| (|c|) (PROG (|n|) (RETURN (PROGN (SPADLET |n| (CHAR2NUM |c|)) (OR (|charRangeTest| |n|) (|charRangeTest| (QSDIFFERENCE (CHAR2NUM |c|) 64))))))) -;charRangeTest n == -; QSLESSP(153,n) => -; QSLESSP(169,n) => false -; QSLESSP(161,n) => true -; false -; QSLESSP(128,n) => -; QSLESSP(144,n) => true -; QSLESSP(138,n) => false -; true -; false - -;;; *** |charRangeTest| REDEFINED - -(DEFUN |charRangeTest| (|n|) (COND ((QSLESSP 153 |n|) (COND ((QSLESSP 169 |n|) NIL) ((QSLESSP 161 |n|) (QUOTE T)) ((QUOTE T) NIL))) ((QSLESSP 128 |n|) (COND ((QSLESSP 144 |n|) (QUOTE T)) ((QSLESSP 138 |n|) NIL) ((QUOTE T) (QUOTE T)))) ((QUOTE T) NIL))) -;update() == -; OBEY -; STRCONC('"SPADEDIT ",STRINGIMAGE _/VERSION,'" ",STRINGIMAGE _/WSNAME,'" A") -; _/UPDATE() - -;;; *** |update| REDEFINED - -(DEFUN |update| NIL (PROGN (OBEY (STRCONC (MAKESTRING "SPADEDIT ") (STRINGIMAGE /VERSION) (MAKESTRING " ") (STRINGIMAGE /WSNAME) (MAKESTRING " A"))) (/UPDATE))) -;listSort(pred,list,:optional) == -; NOT functionp pred => error "listSort: first arg must be a function" -; NOT LISTP list => error "listSort: second argument must be a list" -; NULL optional => mergeSort(pred,function Identity,list,LENGTH list) -; key := CAR optional -; NOT functionp key => error "listSort: last arg must be a function" -; mergeSort(pred,key,list,LENGTH list) - -;;; *** |listSort| REDEFINED - -(DEFUN |listSort| (&REST #0=#:G1410 &AUX |optional| LIST |pred|) (DSETQ (|pred| LIST . |optional|) #0#) (PROG (|key|) (RETURN (COND ((NULL (|functionp| |pred|)) (|error| (QUOTE |listSort: first arg must be a function|))) ((NULL (LISTP LIST)) (|error| (QUOTE |listSort: second argument must be a list|))) ((NULL |optional|) (|mergeSort| |pred| (|function| |Identity|) LIST (LENGTH LIST))) ((QUOTE T) (SPADLET |key| (CAR |optional|)) (COND ((NULL (|functionp| |key|)) (|error| (QUOTE |listSort: last arg must be a function|))) ((QUOTE T) (|mergeSort| |pred| |key| LIST (LENGTH LIST))))))))) -;MSORT list == listSort(function GLESSEQP, COPY_-LIST list) - -;;; *** MSORT REDEFINED - -(DEFUN MSORT (LIST) (|listSort| (|function| GLESSEQP) (COPY-LIST LIST))) -;NMSORT list == listSort(function GLESSEQP, list) - -;;; *** NMSORT REDEFINED - -(DEFUN NMSORT (LIST) (|listSort| (|function| GLESSEQP) LIST)) -;orderList l == listSort(function _?ORDER, COPY_-LIST l) - -;;; *** |orderList| REDEFINED - -(DEFUN |orderList| (|l|) (|listSort| (|function| ?ORDER) (COPY-LIST |l|))) -;mergeInPlace(f,g,p,q) == -; if NULL p then return p -; if NULL q then return q -; if FUNCALL(f,FUNCALL(g, QCAR p),FUNCALL(g, QCAR q)) -; then (r := t := p; p := QCDR p) -; else (r := t := q; q := QCDR q) -; while not NULL p and not NULL q repeat -; if FUNCALL(f,FUNCALL(g,QCAR p),FUNCALL(g,QCAR q)) -; then (QRPLACD(t,p); t := p; p := QCDR p) -; else (QRPLACD(t,q); t := q; q := QCDR q) -; if NULL p then QRPLACD(t,q) else QRPLACD(t,p) -; r - -;;; *** |mergeInPlace| REDEFINED - -(DEFUN |mergeInPlace| (|f| |g| |p| |q|) (PROG (|r| |t|) (RETURN (SEQ (PROGN (COND ((NULL |p|) (RETURN |p|))) (COND ((NULL |q|) (RETURN |q|))) (COND ((FUNCALL |f| (FUNCALL |g| (QCAR |p|)) (FUNCALL |g| (QCAR |q|))) (SPADLET |r| (SPADLET |t| |p|)) (SPADLET |p| (QCDR |p|))) ((QUOTE T) (SPADLET |r| (SPADLET |t| |q|)) (SPADLET |q| (QCDR |q|)))) (DO NIL ((NULL (AND (NULL (NULL |p|)) (NULL (NULL |q|)))) NIL) (SEQ (EXIT (COND ((FUNCALL |f| (FUNCALL |g| (QCAR |p|)) (FUNCALL |g| (QCAR |q|))) (QRPLACD |t| |p|) (SPADLET |t| |p|) (SPADLET |p| (QCDR |p|))) ((QUOTE T) (QRPLACD |t| |q|) (SPADLET |t| |q|) (SPADLET |q| (QCDR |q|))))))) (COND ((NULL |p|) (QRPLACD |t| |q|)) ((QUOTE T) (QRPLACD |t| |p|))) |r|))))) -;mergeSort(f,g,p,n) == -; if EQ(n,2) and FUNCALL(f,FUNCALL(g,QCADR p),FUNCALL(g,QCAR p)) then -; t := p -; p := QCDR p -; QRPLACD(p,t) -; QRPLACD(t,NIL) -; if QSLESSP(n,3) then return p -; -- split the list p into p and q of equal length -; l := QSQUOTIENT(n,2) -; t := p -; for i in 1..l-1 repeat t := QCDR t -; q := rest t -; QRPLACD(t,NIL) -; p := mergeSort(f,g,p,l) -; q := mergeSort(f,g,q,QSDIFFERENCE(n,l)) -; mergeInPlace(f,g,p,q) - -;;; *** |mergeSort| REDEFINED - -(DEFUN |mergeSort| (|f| |g| |p| |n|) (PROG (|l| |t| |q|) (RETURN (SEQ (PROGN (COND ((AND (EQ |n| 2) (FUNCALL |f| (FUNCALL |g| (QCADR |p|)) (FUNCALL |g| (QCAR |p|)))) (SPADLET |t| |p|) (SPADLET |p| (QCDR |p|)) (QRPLACD |p| |t|) (QRPLACD |t| NIL))) (COND ((QSLESSP |n| 3) (RETURN |p|))) (SPADLET |l| (QSQUOTIENT |n| 2)) (SPADLET |t| |p|) (DO ((#0=#:G1411 (SPADDIFFERENCE |l| 1)) (|i| 1 (QSADD1 |i|))) ((QSGREATERP |i| #0#) NIL) (SEQ (EXIT (SPADLET |t| (QCDR |t|))))) (SPADLET |q| (CDR |t|)) (QRPLACD |t| NIL) (SPADLET |p| (|mergeSort| |f| |g| |p| |l|)) (SPADLET |q| (|mergeSort| |f| |g| |q| (QSDIFFERENCE |n| |l|))) (|mergeInPlace| |f| |g| |p| |q|)))))) -;spadThrow() == -; if $interpOnly and $mapName then -; putHist($mapName,'localModemap, nil, $e) -; THROW("SPAD__READER",nil) - -;;; *** |spadThrow| REDEFINED - -(DEFUN |spadThrow| NIL (PROGN (COND ((AND |$interpOnly| |$mapName|) (|putHist| |$mapName| (QUOTE |localModemap|) NIL |$e|))) (THROW (QUOTE SPAD_READER) NIL))) -;spadThrowBrightly x == -; sayBrightly x -; spadThrow() - -;;; *** |spadThrowBrightly| REDEFINED - -(DEFUN |spadThrowBrightly| (|x|) (PROGN (|sayBrightly| |x|) (|spadThrow|))) -;formatUnabbreviatedSig sig == -; null sig => ["() -> ()"] -; [target,:args] := sig -; target := formatUnabbreviated target -; null args => ['"() -> ",:target] -; null rest args => [:formatUnabbreviated QCAR args,'" -> ",:target] -; args := formatUnabbreviatedTuple args -; ['"(",:args,'") -> ",:target] - -;;; *** |formatUnabbreviatedSig| REDEFINED - -(DEFUN |formatUnabbreviatedSig| (|sig|) (PROG (|target| |args|) (RETURN (COND ((NULL |sig|) (CONS (QUOTE |() -> ()|) NIL)) ((QUOTE T) (SPADLET |target| (CAR |sig|)) (SPADLET |args| (CDR |sig|)) (SPADLET |target| (|formatUnabbreviated| |target|)) (COND ((NULL |args|) (CONS (MAKESTRING "() -> ") |target|)) ((NULL (CDR |args|)) (APPEND (|formatUnabbreviated| (QCAR |args|)) (CONS (MAKESTRING " -> ") |target|))) ((QUOTE T) (SPADLET |args| (|formatUnabbreviatedTuple| |args|)) (CONS (MAKESTRING "(") (APPEND |args| (CONS (MAKESTRING ") -> ") |target|)))))))))) -;formatUnabbreviatedTuple t == -; -- t is a list of types -; null t => t -; atom t => [t] -; t0 := formatUnabbreviated QCAR t -; null rest t => t0 -; [:t0,'",",:formatUnabbreviatedTuple QCDR t] - -;;; *** |formatUnabbreviatedTuple| REDEFINED - -(DEFUN |formatUnabbreviatedTuple| (|t|) (PROG (|t0|) (RETURN (COND ((NULL |t|) |t|) ((ATOM |t|) (CONS |t| NIL)) ((QUOTE T) (SPADLET |t0| (|formatUnabbreviated| (QCAR |t|))) (COND ((NULL (CDR |t|)) |t0|) ((QUOTE T) (APPEND |t0| (CONS (MAKESTRING ",") (|formatUnabbreviatedTuple| (QCDR |t|))))))))))) -;formatUnabbreviated t == -; atom t => -; [t] -; null t => -; ['"()"] -; t is [p,sel,arg] and p in '(_: ":") => -; [sel,'": ",:formatUnabbreviated arg] -; t is ['Union,:args] => -; ['Union,'"(",:formatUnabbreviatedTuple args,'")"] -; t is ['Mapping,:args] => -; formatUnabbreviatedSig args -; t is ['Record,:args] => -; ['Record,'"(",:formatUnabbreviatedTuple args,'")"] -; t is [arg] => -; t -; t is [arg,arg1] => -; [arg,'" ",:formatUnabbreviated arg1] -; t is [arg,:args] => -; [arg,'"(",:formatUnabbreviatedTuple args,'")"] -; t - -;;; *** |formatUnabbreviated| REDEFINED - -(DEFUN |formatUnabbreviated| (|t|) (PROG (|p| |sel| |ISTMP#2| |ISTMP#1| |arg1| |arg| |args|) (RETURN (COND ((ATOM |t|) (CONS |t| NIL)) ((NULL |t|) (CONS (MAKESTRING "()") NIL)) ((AND (PAIRP |t|) (PROGN (SPADLET |p| (QCAR |t|)) (SPADLET |ISTMP#1| (QCDR |t|)) (AND (PAIRP |ISTMP#1|) (PROGN (SPADLET |sel| (QCAR |ISTMP#1|)) (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) (PROGN (SPADLET |arg| (QCAR |ISTMP#2|)) (QUOTE T)))))) (|member| |p| (QUOTE (|:| ":")))) (CONS |sel| (CONS (MAKESTRING ": ") (|formatUnabbreviated| |arg|)))) ((AND (PAIRP |t|) (EQ (QCAR |t|) (QUOTE |Union|)) (PROGN (SPADLET |args| (QCDR |t|)) (QUOTE T))) (CONS (QUOTE |Union|) (CONS (MAKESTRING "(") (APPEND (|formatUnabbreviatedTuple| |args|) (CONS (MAKESTRING ")") NIL))))) ((AND (PAIRP |t|) (EQ (QCAR |t|) (QUOTE |Mapping|)) (PROGN (SPADLET |args| (QCDR |t|)) (QUOTE T))) (|formatUnabbreviatedSig| |args|)) ((AND (PAIRP |t|) (EQ (QCAR |t|) (QUOTE |Record|)) (PROGN (SPADLET |args| (QCDR |t|)) (QUOTE T))) (CONS (QUOTE |Record|) (CONS (MAKESTRING "(") (APPEND (|formatUnabbreviatedTuple| |args|) (CONS (MAKESTRING ")") NIL))))) ((AND (PAIRP |t|) (EQ (QCDR |t|) NIL) (PROGN (SPADLET |arg| (QCAR |t|)) (QUOTE T))) |t|) ((AND (PAIRP |t|) (PROGN (SPADLET |arg| (QCAR |t|)) (SPADLET |ISTMP#1| (QCDR |t|)) (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) (PROGN (SPADLET |arg1| (QCAR |ISTMP#1|)) (QUOTE T))))) (CONS |arg| (CONS (MAKESTRING " ") (|formatUnabbreviated| |arg1|)))) ((AND (PAIRP |t|) (PROGN (SPADLET |arg| (QCAR |t|)) (SPADLET |args| (QCDR |t|)) (QUOTE T))) (CONS |arg| (CONS (MAKESTRING "(") (APPEND (|formatUnabbreviatedTuple| |args|) (CONS (MAKESTRING ")") NIL))))) ((QUOTE T) |t|))))) -;sublisNQ(al,e) == -; atom al => e -; fn(al,e) where fn(al,e) == -; atom e => -; for x in al repeat -; EQ(first x,e) => return (e := rest x) -; e -; EQ(a := first e,'QUOTE) => e -; u := fn(al,a) -; v := fn(al,rest e) -; EQ(a,u) and EQ(rest e,v) => e -; [u,:v] - -;;; *** |sublisNQ,fn| REDEFINED - -(DEFUN |sublisNQ,fn| (|al| |e|) (PROG (|a| |u| |v|) (RETURN (SEQ (IF (ATOM |e|) (EXIT (SEQ (DO ((#0=#:G1412 |al| (CDR #0#)) (|x| NIL)) ((OR (ATOM #0#) (PROGN (SETQ |x| (CAR #0#)) NIL)) NIL) (SEQ (EXIT (IF (EQ (CAR |x|) |e|) (EXIT (RETURN (SPADLET |e| (CDR |x|)))))))) (EXIT |e|)))) (IF (EQ (SPADLET |a| (CAR |e|)) (QUOTE QUOTE)) (EXIT |e|)) (SPADLET |u| (|sublisNQ,fn| |al| |a|)) (SPADLET |v| (|sublisNQ,fn| |al| (CDR |e|))) (IF (AND (EQ |a| |u|) (EQ (CDR |e|) |v|)) (EXIT |e|)) (EXIT (CONS |u| |v|)))))) - -;;; *** |sublisNQ| REDEFINED - -(DEFUN |sublisNQ| (|al| |e|) (COND ((ATOM |al|) |e|) ((QUOTE T) (|sublisNQ,fn| |al| |e|)))) -;str2Outform s == -; parse := ncParseFromString s or systemError '"String for TeX will not parse" -; parse2Outform parse - -;;; *** |str2Outform| REDEFINED - -(DEFUN |str2Outform| (|s|) (PROG (|parse|) (RETURN (PROGN (SPADLET |parse| (OR (|ncParseFromString| |s|) (|systemError| (MAKESTRING "String for TeX will not parse")))) (|parse2Outform| |parse|))))) -;parse2Outform x == -; x is [op,:argl] => -; nargl := [parse2Outform y for y in argl] -; op = 'construct => ['BRACKET,['ARGLST,:[parse2Outform y for y in argl]]] -; op = 'brace and nargl is [[BRACKET,:r]] => ['BRACE,:r] -; [op,:nargl] -; x - -;;; *** |parse2Outform| REDEFINED - -(DEFUN |parse2Outform| (|x|) (PROG (|op| |argl| |nargl| |ISTMP#1| BRACKET |r|) (RETURN (SEQ (COND ((AND (PAIRP |x|) (PROGN (SPADLET |op| (QCAR |x|)) (SPADLET |argl| (QCDR |x|)) (QUOTE T))) (SPADLET |nargl| (PROG (#0=#:G1413) (SPADLET #0# NIL) (RETURN (DO ((#1=#:G1414 |argl| (CDR #1#)) (|y| NIL)) ((OR (ATOM #1#) (PROGN (SETQ |y| (CAR #1#)) NIL)) (NREVERSE0 #0#)) (SEQ (EXIT (SETQ #0# (CONS (|parse2Outform| |y|) #0#)))))))) (COND ((BOOT-EQUAL |op| (QUOTE |construct|)) (CONS (QUOTE BRACKET) (CONS (CONS (QUOTE ARGLST) (PROG (#2=#:G1415) (SPADLET #2# NIL) (RETURN (DO ((#3=#:G1416 |argl| (CDR #3#)) (|y| NIL)) ((OR (ATOM #3#) (PROGN (SETQ |y| (CAR #3#)) NIL)) (NREVERSE0 #2#)) (SEQ (EXIT (SETQ #2# (CONS (|parse2Outform| |y|) #2#)))))))) NIL))) ((AND (BOOT-EQUAL |op| (QUOTE |brace|)) (PAIRP |nargl|) (EQ (QCDR |nargl|) NIL) (PROGN (SPADLET |ISTMP#1| (QCAR |nargl|)) (AND (PAIRP |ISTMP#1|) (PROGN (SPADLET BRACKET (QCAR |ISTMP#1|)) (SPADLET |r| (QCDR |ISTMP#1|)) (QUOTE T))))) (CONS (QUOTE BRACE) |r|)) ((QUOTE T) (CONS |op| |nargl|)))) ((QUOTE T) |x|)))))) -;str2Tex s == -; outf := str2Outform s -; val := coerceInt(mkObj(wrap outf, '(OutputForm)), '(TexFormat)) -; val := objValUnwrap val -; CAR val.1 - -;;; *** |str2Tex| REDEFINED - -(DEFUN |str2Tex| (|s|) (PROG (|outf| |val|) (RETURN (PROGN (SPADLET |outf| (|str2Outform| |s|)) (SPADLET |val| (|coerceInt| (|mkObj| (|wrap| |outf|) (QUOTE (|OutputForm|))) (QUOTE (|TexFormat|)))) (SPADLET |val| (|objValUnwrap| |val|)) (CAR (ELT |val| 1)))))) -;opOf x == -; atom x => x -; first x - -;;; *** |opOf| REDEFINED - -(DEFUN |opOf| (|x|) (COND ((ATOM |x|) |x|) ((QUOTE T) (CAR |x|)))) -;getProplist(x,E) == -; not atom x => getProplist(first x,E) -; u:= search(x,E) => u -; --$InteractiveMode => nil -; --$InteractiveMode and (u:= search(x,$InteractiveFrame)) => u -; (pl:=search(x,$CategoryFrame)) => -; pl - -;;; *** |getProplist| REDEFINED - -(DEFUN |getProplist| (|x| E) (PROG (|u| |pl|) (RETURN (COND ((NULL (ATOM |x|)) (|getProplist| (CAR |x|) E)) ((SPADLET |u| (|search| |x| E)) |u|) ((SPADLET |pl| (|search| |x| |$CategoryFrame|)) |pl|))))) -;-- (pl:=PROPLIST x) => pl -;-- Above line commented out JHD/BMT 2.Aug.90 -;search(x,e is [curEnv,:tailEnv]) == -; searchCurrentEnv(x,curEnv) or searchTailEnv(x,tailEnv) - -;;; *** |search| REDEFINED - -(DEFUN |search| (|x| |e|) (PROG (|curEnv| |tailEnv|) (RETURN (PROGN (SPADLET |curEnv| (CAR |e|)) (SPADLET |tailEnv| (CDR |e|)) (OR (|searchCurrentEnv| |x| |curEnv|) (|searchTailEnv| |x| |tailEnv|)))))) -;searchCurrentEnv(x,currentEnv) == -; for contour in currentEnv repeat -; if u:= ASSQ(x,contour) then return (signal:= u) -; KDR signal - -;;; *** |searchCurrentEnv| REDEFINED - -(DEFUN |searchCurrentEnv| (|x| |currentEnv|) (PROG (|u| |signal|) (RETURN (SEQ (PROGN (DO ((#0=#:G1417 |currentEnv| (CDR #0#)) (|contour| NIL)) ((OR (ATOM #0#) (PROGN (SETQ |contour| (CAR #0#)) NIL)) NIL) (SEQ (EXIT (COND ((SPADLET |u| (ASSQ |x| |contour|)) (RETURN (SPADLET |signal| |u|))) ((QUOTE T) NIL))))) (KDR |signal|)))))) -;searchTailEnv(x,e) == -; for env in e repeat -; signal:= -; for contour in env repeat -; if (u:= ASSQ(x,contour)) and ASSQ("FLUID",u) then return (signal:= u) -; if signal then return signal -; KDR signal - -;;; *** |searchTailEnv| REDEFINED - -(DEFUN |searchTailEnv| (|x| |e|) (PROG (|u| |signal|) (RETURN (SEQ (PROGN (DO ((#0=#:G1418 |e| (CDR #0#)) (|env| NIL)) ((OR (ATOM #0#) (PROGN (SETQ |env| (CAR #0#)) NIL)) NIL) (SEQ (EXIT (SPADLET |signal| (PROGN (DO ((#1=#:G1419 |env| (CDR #1#)) (|contour| NIL)) ((OR (ATOM #1#) (PROGN (SETQ |contour| (CAR #1#)) NIL)) NIL) (SEQ (EXIT (COND ((AND (SPADLET |u| (ASSQ |x| |contour|)) (ASSQ (QUOTE FLUID) |u|)) (RETURN (SPADLET |signal| |u|))) ((QUOTE T) NIL))))) (COND (|signal| (RETURN |signal|)) ((QUOTE T) NIL))))))) (KDR |signal|)))))) -;augProplist(proplist,prop,val) == -; $InteractiveMode => augProplistInteractive(proplist,prop,val) -; while (proplist is [[ =prop,:.],:proplist']) repeat proplist:= proplist' -; val=(u:= LASSOC(prop,proplist)) => proplist -; null val => -; null u => proplist -; DELLASOS(prop,proplist) -; [[prop,:val],:proplist] - -;;; *** |augProplist| REDEFINED - -(DEFUN |augProplist| (|proplist| |prop| |val|) (PROG (|ISTMP#1| |proplist'| |u|) (RETURN (SEQ (COND (|$InteractiveMode| (|augProplistInteractive| |proplist| |prop| |val|)) ((QUOTE T) (DO NIL ((NULL (AND (PAIRP |proplist|) (PROGN (SPADLET |ISTMP#1| (QCAR |proplist|)) (AND (PAIRP |ISTMP#1|) (EQUAL (QCAR |ISTMP#1|) |prop|))) (PROGN (SPADLET |proplist'| (QCDR |proplist|)) (QUOTE T)))) NIL) (SEQ (EXIT (SPADLET |proplist| |proplist'|)))) (COND ((BOOT-EQUAL |val| (SPADLET |u| (LASSOC |prop| |proplist|))) |proplist|) ((NULL |val|) (COND ((NULL |u|) |proplist|) ((QUOTE T) (DELLASOS |prop| |proplist|)))) ((QUOTE T) (CONS (CONS |prop| |val|) |proplist|))))))))) -;augProplistOf(var,prop,val,e) == -; proplist:= getProplist(var,e) -; semchkProplist(var,proplist,prop,val) -; augProplist(proplist,prop,val) - -;;; *** |augProplistOf| REDEFINED - -(DEFUN |augProplistOf| (|var| |prop| |val| |e|) (PROG (|proplist|) (RETURN (PROGN (SPADLET |proplist| (|getProplist| |var| |e|)) (|semchkProplist| |var| |proplist| |prop| |val|) (|augProplist| |proplist| |prop| |val|))))) -;semchkProplist(x,proplist,prop,val) == -; prop="isLiteral" => -; LASSOC("value",proplist) or LASSOC("mode",proplist) => warnLiteral x -; MEMQ(prop,'(mode value)) => -; LASSOC("isLiteral",proplist) => warnLiteral x - -;;; *** |semchkProplist| REDEFINED - -(DEFUN |semchkProplist| (|x| |proplist| |prop| |val|) (SEQ (COND ((BOOT-EQUAL |prop| (QUOTE |isLiteral|)) (COND ((OR (LASSOC (QUOTE |value|) |proplist|) (LASSOC (QUOTE |mode|) |proplist|)) (EXIT (|warnLiteral| |x|))))) ((MEMQ |prop| (QUOTE (|mode| |value|))) (COND ((LASSOC (QUOTE |isLiteral|) |proplist|) (EXIT (|warnLiteral| |x|)))))))) -;DEFPARAMETER($envHashTable,nil) - -(DEFPARAMETER |$envHashTable| NIL) -;addBinding(var,proplist,e is [[curContour,:tailContour],:tailEnv]) == -; EQ(proplist,getProplist(var,e)) => e -; if $envHashTable then -; for u in proplist repeat -; HPUT($envHashTable,[var, CAR u],true) -; $InteractiveMode => addBindingInteractive(var,proplist,e) -; if curContour is [[ =var,:.],:.] then curContour:= rest curContour -; --Previous line should save some space -; [[[lx,:curContour],:tailContour],:tailEnv] where lx:= [var,:proplist] - -;;; *** |addBinding| REDEFINED - -(DEFUN |addBinding| (|var| |proplist| |e|) (PROG (|tailContour| |tailEnv| |ISTMP#1| |curContour| |lx|) (RETURN (SEQ (PROGN (SPADLET |curContour| (CAAR |e|)) (SPADLET |tailContour| (CDAR |e|)) (SPADLET |tailEnv| (CDR |e|)) (COND ((EQ |proplist| (|getProplist| |var| |e|)) |e|) ((QUOTE T) (COND (|$envHashTable| (DO ((#0=#:G1420 |proplist| (CDR #0#)) (|u| NIL)) ((OR (ATOM #0#) (PROGN (SETQ |u| (CAR #0#)) NIL)) NIL) (SEQ (EXIT (HPUT |$envHashTable| (CONS |var| (CONS (CAR |u|) NIL)) (QUOTE T))))))) (COND (|$InteractiveMode| (|addBindingInteractive| |var| |proplist| |e|)) ((QUOTE T) (COND ((AND (PAIRP |curContour|) (PROGN (SPADLET |ISTMP#1| (QCAR |curContour|)) (AND (PAIRP |ISTMP#1|) (EQUAL (QCAR |ISTMP#1|) |var|)))) (SPADLET |curContour| (CDR |curContour|)))) (SPADLET |lx| (CONS |var| |proplist|)) (CONS (CONS (CONS |lx| |curContour|) |tailContour|) |tailEnv|)))))))))) -;position(x,l) == -; posn(x,l,0) where -; posn(x,l,n) == -; null l => -1 -; x=first l => n -; posn(x,rest l,n+1) - -;;; *** |position,posn| REDEFINED - -(DEFUN |position,posn| (|x| |l| |n|) (SEQ (IF (NULL |l|) (EXIT (SPADDIFFERENCE 1))) (IF (BOOT-EQUAL |x| (CAR |l|)) (EXIT |n|)) (EXIT (|position,posn| |x| (CDR |l|) (PLUS |n| 1))))) - -;;; *** |position| REDEFINED - -(DEFUN |position| (|x| |l|) (|position,posn| |x| |l| 0)) -;insert(x,y) == -; MEMBER(x,y) => y -; [x,:y] - -;;; *** |insert| REDEFINED - -(DEFUN |insert| (|x| |y|) (COND ((|member| |x| |y|) |y|) ((QUOTE T) (CONS |x| |y|)))) -;after(u,v) == -; r:= u -; for x in u for y in v repeat r:= rest r -; r - -;;; *** |after| REDEFINED - -(DEFUN |after| (|u| |v|) (PROG (|r|) (RETURN (SEQ (PROGN (SPADLET |r| |u|) (DO ((#0=#:G1421 |u| (CDR #0#)) (|x| NIL) (#1=#:G1422 |v| (CDR #1#)) (|y| NIL)) ((OR (ATOM #0#) (PROGN (SETQ |x| (CAR #0#)) NIL) (ATOM #1#) (PROGN (SETQ |y| (CAR #1#)) NIL)) NIL) (SEQ (EXIT (SPADLET |r| (CDR |r|))))) |r|))))) -;$blank := char ('_ ) - -(SPADLET |$blank| (|char| (QUOTE | |))) -;trimString s == -; leftTrim rightTrim s - -;;; *** |trimString| REDEFINED - -(DEFUN |trimString| (|s|) (|leftTrim| (|rightTrim| |s|))) -;leftTrim s == -; k := MAXINDEX s -; k < 0 => s -; s.0 = $blank => -; for i in 0..k while s.i = $blank repeat (j := i) -; SUBSTRING(s,j + 1,nil) -; s - -;;; *** |leftTrim| REDEFINED - -(DEFUN |leftTrim| (|s|) (PROG (|k| |j|) (RETURN (SEQ (PROGN (SPADLET |k| (MAXINDEX |s|)) (COND ((MINUSP |k|) |s|) ((BOOT-EQUAL (ELT |s| 0) |$blank|) (DO ((|i| 0 (QSADD1 |i|))) ((OR (QSGREATERP |i| |k|) (NULL (BOOT-EQUAL (ELT |s| |i|) |$blank|))) NIL) (SEQ (EXIT (SPADLET |j| |i|)))) (SUBSTRING |s| (PLUS |j| 1) NIL)) ((QUOTE T) |s|))))))) -;rightTrim s == -- assumed a non-empty string -; k := MAXINDEX s -; k < 0 => s -; s.k = $blank => -; for i in k..0 by -1 while s.i = $blank repeat (j := i) -; SUBSTRING(s,0,j) -; s - -;;; *** |rightTrim| REDEFINED - -(DEFUN |rightTrim| (|s|) (PROG (|k| |j|) (RETURN (SEQ (PROGN (SPADLET |k| (MAXINDEX |s|)) (COND ((MINUSP |k|) |s|) ((BOOT-EQUAL (ELT |s| |k|) |$blank|) (DO ((#0=#:G1423 (SPADDIFFERENCE 1)) (|i| |k| (+ |i| #0#))) ((OR (IF (MINUSP #0#) (< |i| 0) (> |i| 0)) (NULL (BOOT-EQUAL (ELT |s| |i|) |$blank|))) NIL) (SEQ (EXIT (SPADLET |j| |i|)))) (SUBSTRING |s| 0 |j|)) ((QUOTE T) |s|))))))) -;pp x == -; PRETTYPRINT x -; x - -;;; *** |pp| REDEFINED - -(DEFUN |pp| (|x|) (PROGN (PRETTYPRINT |x|) |x|)) -;pr x == -; F_,PRINT_-ONE x -; nil - -;;; *** |pr| REDEFINED - -(DEFUN |pr| (|x|) (PROGN (|F,PRINT-ONE| |x|) NIL)) -;quickAnd(a,b) == -; a = true => b -; b = true => a -; a = false or b = false => false -; simpBool ['AND,a,b] - -;;; *** |quickAnd| REDEFINED - -(DEFUN |quickAnd| (|a| |b|) (COND ((BOOT-EQUAL |a| (QUOTE T)) |b|) ((BOOT-EQUAL |b| (QUOTE T)) |a|) ((OR (NULL |a|) (NULL |b|)) NIL) ((QUOTE T) (|simpBool| (CONS (QUOTE AND) (CONS |a| (CONS |b| NIL))))))) -;quickOr(a,b) == -; a = true or b = true => true -; b = false => a -; a = false => b -; simpCatPredicate simpBool ['OR,a,b] - -;;; *** |quickOr| REDEFINED - -(DEFUN |quickOr| (|a| |b|) (COND ((OR (BOOT-EQUAL |a| (QUOTE T)) (BOOT-EQUAL |b| (QUOTE T))) (QUOTE T)) ((NULL |b|) |a|) ((NULL |a|) |b|) ((QUOTE T) (|simpCatPredicate| (|simpBool| (CONS (QUOTE OR) (CONS |a| (CONS |b| NIL)))))))) -;intern x == -; STRINGP x => -; DIGITP x.0 => string2Integer x -; INTERN x -; x - -;;; *** |intern| REDEFINED - -(DEFUN |intern| (|x|) (COND ((STRINGP |x|) (COND ((DIGITP (ELT |x| 0)) (|string2Integer| |x|)) ((QUOTE T) (INTERN |x|)))) ((QUOTE T) |x|))) -;isDomain a == -; PAIRP a and VECP(CAR a) and -; MEMBER(CAR(a).0, $domainTypeTokens) - -;;; *** |isDomain| REDEFINED - -(DEFUN |isDomain| (|a|) (AND (PAIRP |a|) (VECP (CAR |a|)) (|member| (ELT (CAR |a|) 0) |$domainTypeTokens|))) -;$htHash := MAKE_-HASH_-TABLE() - -(SPADLET |$htHash| (MAKE-HASH-TABLE)) -;$glossHash := MAKE_-HASH_-TABLE() - -(SPADLET |$glossHash| (MAKE-HASH-TABLE)) -;$lispHash := MAKE_-HASH_-TABLE() - -(SPADLET |$lispHash| (MAKE-HASH-TABLE)) -;$sysHash := MAKE_-HASH_-TABLE() - -(SPADLET |$sysHash| (MAKE-HASH-TABLE)) -;$htSystemCommands := '( -; (boot . development) clear display (fin . development) edit help -; frame history load quit read set show synonym system -; trace what ) - -(SPADLET |$htSystemCommands| (QUOTE ((|boot| . |development|) |clear| |display| (|fin| . |development|) |edit| |help| |frame| |history| |load| |quit| |read| |set| |show| |synonym| |system| |trace| |what|))) -;$currentSysList := [opOf x for x in $htSystemCommands] --see ht-root - -(SPADLET |$currentSysList| (COLLECT (IN |x| |$htSystemCommands|) (|opOf| |x|))) -;$outStream := nil - -(SPADLET |$outStream| NIL) -;$recheckingFlag := false --see transformAndRecheckComments - -(SPADLET |$recheckingFlag| NIL) -;$exposeFlag := false --if true, messages go to $outStream - -(SPADLET |$exposeFlag| NIL) -;$exposeFlagHeading := false --see htcheck.boot - -(SPADLET |$exposeFlagHeading| NIL) -;$checkingXmptex? := false --see htcheck.boot - -(SPADLET |$checkingXmptex?| NIL) -;$exposeDocHeading:= nil --see htcheck.boot - -(SPADLET |$exposeDocHeading| NIL) -;$charPlus := char '_+ - -(SPADLET |$charPlus| (|char| (QUOTE +))) -;$charBlank:= (char '_ ) - -(SPADLET |$charBlank| (|char| (QUOTE | |))) -;$charLbrace:= char '_{ - -(SPADLET |$charLbrace| (|char| (QUOTE {))) -;$charRbrace:= char '_} - -(SPADLET |$charRbrace| (|char| (QUOTE }))) -;$charBack := char '_\ - -(SPADLET |$charBack| (|char| (QUOTE |\\|))) -;$charDash := char '_- - -(SPADLET |$charDash| (|char| (QUOTE -))) -;$charTab := CODE_-CHAR(9) - -(SPADLET |$charTab| (CODE-CHAR 9)) -;$charNewline := CODE_-CHAR(10) - -(SPADLET |$charNewline| (CODE-CHAR 10)) -;$charFauxNewline := CODE_-CHAR(25) - -(SPADLET |$charFauxNewline| (CODE-CHAR 25)) -;$stringNewline := PNAME CODE_-CHAR(10) - -(SPADLET |$stringNewline| (PNAME (CODE-CHAR 10))) -;$stringFauxNewline := PNAME CODE_-CHAR(25) - -(SPADLET |$stringFauxNewline| (PNAME (CODE-CHAR 25))) -;$charExclusions := [char 'a, char 'A] - -(SPADLET |$charExclusions| (CONS (|char| (QUOTE |a|)) (CONS (|char| (QUOTE A)) NIL))) -;$charQuote := char '_' - -(SPADLET |$charQuote| (|char| (QUOTE |'|))) -;$charSemiColon := char '_; - -(SPADLET |$charSemiColon| (|char| (QUOTE |;|))) -;$charComma := char '_, - -(SPADLET |$charComma| (|char| (QUOTE |,|))) -;$charPeriod := char '_. - -(SPADLET |$charPeriod| (|char| (INTERN "." "BOOT"))) -;$checkPrenAlist := [[char '_(,:char '_)],[char '_{,:char '_}],[char '_[,:char '_]]] - -(SPADLET |$checkPrenAlist| (CONS (CONS (|char| (QUOTE |(|)) (|char| (QUOTE |)|))) (CONS (CONS (|char| (QUOTE {)) (|char| (QUOTE }))) (CONS (CONS (|char| (QUOTE [)) (|char| (QUOTE ]))) NIL)))) -;$charEscapeList:= [char '_%,char '_#,$charBack] - -(SPADLET |$charEscapeList| (CONS (|char| (QUOTE %)) (CONS (|char| (QUOTE |#|)) (CONS |$charBack| NIL)))) -;$charIdentifierEndings := [char '__, char '_!, char '_?] - -(SPADLET |$charIdentifierEndings| (CONS (|char| (QUOTE _)) (CONS (|char| (QUOTE !)) (CONS (|char| (QUOTE ?)) NIL)))) -;$charSplitList := [$charComma,$charPeriod,char '_[, char '_],$charLbrace, $charRbrace, char '_(, char '_), char '_$, char '_%] - -(SPADLET |$charSplitList| (CONS |$charComma| (CONS |$charPeriod| (CONS (|char| (QUOTE [)) (CONS (|char| (QUOTE ])) (CONS |$charLbrace| (CONS |$charRbrace| (CONS (|char| (QUOTE |(|)) (CONS (|char| (QUOTE |)|)) (CONS (|char| (QUOTE $)) (CONS (|char| (QUOTE %)) NIL))))))))))) -;$charDelimiters := [$charBlank, char '_(, char '_), $charBack] - -(SPADLET |$charDelimiters| (CONS |$charBlank| (CONS (|char| (QUOTE |(|)) (CONS (|char| (QUOTE |)|)) (CONS |$charBack| NIL))))) -;$HTspadmacros := '("\spadtype" "\spadcommand" "\spadop" "\spadfun" "\spadatt" "\spadsyscom" "\spad" "\s") - -(SPADLET |$HTspadmacros| (QUOTE ("\\spadtype" "\\spadcommand" "\\spadop" "\\spadfun" "\\spadatt" "\\spadsyscom" "\\spad" "\\s"))) -;$HTmacs := [ -; ['"\beginmenu",$charRbrace,'"menu",$charLbrace,'"\begin"], -; ['"\endmenu",$charRbrace,'"menu",$charLbrace,'"\end"], -; ['"\beginitems",$charRbrace,'"items",$charLbrace,'"\begin"], -; ['"\enditems",$charRbrace,'"items",$charLbrace,'"\end"], -; ['"\beginscroll",$charRbrace,'"scroll",$charLbrace,'"\begin"], -; ['"\endscroll",$charRbrace,'"scroll",$charLbrace,'"\end"]] - -(SPADLET |$HTmacs| (CONS (CONS (MAKESTRING "\\beginmenu") (CONS |$charRbrace| (CONS (MAKESTRING "menu") (CONS |$charLbrace| (CONS (MAKESTRING "\\begin") NIL))))) (CONS (CONS (MAKESTRING "\\endmenu") (CONS |$charRbrace| (CONS (MAKESTRING "menu") (CONS |$charLbrace| (CONS (MAKESTRING "\\end") NIL))))) (CONS (CONS (MAKESTRING "\\beginitems") (CONS |$charRbrace| (CONS (MAKESTRING "items") (CONS |$charLbrace| (CONS (MAKESTRING "\\begin") NIL))))) (CONS (CONS (MAKESTRING "\\enditems") (CONS |$charRbrace| (CONS (MAKESTRING "items") (CONS |$charLbrace| (CONS (MAKESTRING "\\end") NIL))))) (CONS (CONS (MAKESTRING "\\beginscroll") (CONS |$charRbrace| (CONS (MAKESTRING "scroll") (CONS |$charLbrace| (CONS (MAKESTRING "\\begin") NIL))))) (CONS (CONS (MAKESTRING "\\endscroll") (CONS |$charRbrace| (CONS (MAKESTRING "scroll") (CONS |$charLbrace| (CONS (MAKESTRING "\\end") NIL))))) NIL))))))) -;$HTlinks := '( -; "\downlink" -; "\menulink" -; "\menudownlink" -; "\menuwindowlink" -; "\menumemolink") - -(SPADLET |$HTlinks| (QUOTE ("\\downlink" "\\menulink" "\\menudownlink" "\\menuwindowlink" "\\menumemolink"))) -;$HTlisplinks := '( -; "\lispdownlink" -; "\menulispdownlink" -; "\menulispwindowlink" -; "\menulispmemolink" -; "\lispwindowlink" -; "\lispmemolink") - -(SPADLET |$HTlisplinks| (QUOTE ("\\lispdownlink" "\\menulispdownlink" "\\menulispwindowlink" "\\menulispmemolink" "\\lispwindowlink" "\\lispmemolink"))) -;$beginEndList := '( -; "page" -; "items" -; "menu" -; "scroll" -; "verbatim" -; "detail") - -(SPADLET |$beginEndList| (QUOTE ("page" "items" "menu" "scroll" "verbatim" "detail"))) -;isDefaultPackageName x == (s := PNAME x).(MAXINDEX s) = char '_& - -;;; *** |isDefaultPackageName| REDEFINED - -(DEFUN |isDefaultPackageName| (|x|) (PROG (|s|) (RETURN (BOOT-EQUAL (ELT (SPADLET |s| (PNAME |x|)) (MAXINDEX |s|)) (|char| (QUOTE &)))))) -;;;Boot translation finished for g-util.boot - -@ -\section{License} -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/g-util.lisp.pamphlet b/src/interp/g-util.lisp.pamphlet new file mode 100644 index 0000000..3ab1f6b --- /dev/null +++ b/src/interp/g-util.lisp.pamphlet @@ -0,0 +1,1741 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp g-util.lisp} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +<<*>>= + +(IN-PACKAGE "BOOT" ) + +;PPtoFile(x, fname) == +; stream := DEFIOSTREAM([['MODE, :'OUTPUT], ['FILE, :fname]], 80, 0) +; PRETTYPRINT(x, stream) +; SHUT stream +; x + +(DEFUN |PPtoFile| (|x| |fname|) + (PROG (|stream|) + (RETURN + (PROGN + (SPADLET |stream| + (DEFIOSTREAM + (CONS + (CONS (QUOTE MODE) (QUOTE OUTPUT)) + (CONS (CONS (QUOTE FILE) |fname|) NIL)) + 80 0)) + (PRETTYPRINT |x| |stream|) (SHUT |stream|) |x|)))) + +;bool x == +; NULL NULL x + +(DEFUN |bool| (|x|) (NULL (NULL |x|))) + +;Identity x == x + +(DEFUN |Identity| (|x|) |x|) + +;length1? l == PAIRP l and not PAIRP QCDR l + +(DEFUN |length1?| (|l|) (AND (PAIRP |l|) (NULL (PAIRP (QCDR |l|))))) + +;length2? l == PAIRP l and PAIRP (l := QCDR l) and not PAIRP QCDR l + +(DEFUN |length2?| (|l|) + (AND (PAIRP |l|) (PAIRP (SPADLET |l| (QCDR |l|))) (NULL (PAIRP (QCDR |l|))))) + +;pairList(u,v) == [[x,:y] for x in u for y in v] + +(DEFUN |pairList| (|u| |v|) + (PROG NIL + (RETURN + (SEQ + (PROG (#0=#:G1403) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G1404 |u| (CDR #1#)) + (|x| NIL) + (#2=#:G1405 |v| (CDR #2#)) + (|y| NIL)) + ((OR (ATOM #1#) + (PROGN (SETQ |x| (CAR #1#)) NIL) + (ATOM #2#) + (PROGN (SETQ |y| (CAR #2#)) NIL)) + (NREVERSE0 #0#)) + (SEQ (EXIT (SETQ #0# (CONS (CONS |x| |y|) #0#))))))))))) + +;GETALIST(alist,prop) == CDR assoc(prop,alist) + +(DEFUN GETALIST (|alist| |prop|) (CDR (|assoc| |prop| |alist|))) + +;PUTALIST(alist,prop,val) == +; null alist => [[prop,:val]] +; pair := assoc(prop,alist) => +; CDR pair = val => alist +; -- else we fall over Lucid's read-only storage feature again +; QRPLACD(pair,val) +; alist +; QRPLACD(LASTPAIR alist,[[prop,:val]]) +; alist + +(DEFUN PUTALIST (|alist| |prop| |val|) + (PROG (|pair|) + (RETURN + (COND + ((NULL |alist|) (CONS (CONS |prop| |val|) NIL)) + ((SPADLET |pair| (|assoc| |prop| |alist|)) + (COND + ((BOOT-EQUAL (CDR |pair|) |val|) |alist|) + ((QUOTE T) (QRPLACD |pair| |val|) |alist|))) + ((QUOTE T) + (QRPLACD (LASTPAIR |alist|) (CONS (CONS |prop| |val|) NIL)) + |alist|))))) + +;REMALIST(alist,prop) == +; null alist => alist +; alist is [[ =prop,:.],:r] => +; null r => NIL +; QRPLACA(alist,CAR r) +; QRPLACD(alist,CDR r) +; alist +; null rest alist => alist +; l := alist +; ok := true +; while ok repeat +; [.,[p,:.],:r] := l +; p = prop => +; ok := NIL +; QRPLACD(l,r) +; if null (l := QCDR l) or null rest l then ok := NIL +; alist + +(DEFUN REMALIST (|alist| |prop|) + (PROG (|ISTMP#1| |p| |r| |l| |ok|) + (RETURN + (SEQ + (COND + ((NULL |alist|) |alist|) + ((AND + (PAIRP |alist|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |alist|)) + (AND (PAIRP |ISTMP#1|) (EQUAL (QCAR |ISTMP#1|) |prop|))) + (PROGN (SPADLET |r| (QCDR |alist|)) (QUOTE T))) + (COND + ((NULL |r|) NIL) + ((QUOTE T) + (QRPLACA |alist| (CAR |r|)) + (QRPLACD |alist| (CDR |r|)) + |alist|))) + ((NULL (CDR |alist|)) |alist|) + ((QUOTE T) + (SPADLET |l| |alist|) + (SPADLET |ok| (QUOTE T)) + (DO () + ((NULL |ok|) + NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |p| (CAADR |l|)) + (SPADLET |r| (CDDR |l|)) + (COND + ((BOOT-EQUAL |p| |prop|) (SPADLET |ok| NIL) (QRPLACD |l| |r|)) + ((OR (NULL (SPADLET |l| (QCDR |l|))) (NULL (CDR |l|))) + (SPADLET |ok| NIL)) + ((QUOTE T) NIL)))))) + |alist|)))))) + +;deleteLassoc(x,y) == +; y is [[a,:.],:y'] => +; EQ(x,a) => y' +; [first y,:deleteLassoc(x,y')] +; y + +(DEFUN |deleteLassoc| (|x| |y|) + (PROG (|ISTMP#1| |a| |y'|) + (RETURN + (COND + ((AND + (PAIRP |y|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |y|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN (SPADLET |a| (QCAR |ISTMP#1|)) (QUOTE T)))) + (PROGN (SPADLET |y'| (QCDR |y|)) (QUOTE T))) + (COND + ((EQ |x| |a|) |y'|) + ((QUOTE T) (CONS (CAR |y|) (|deleteLassoc| |x| |y'|))))) + ((QUOTE T) |y|))))) + +;deleteAssoc(x,y) == +; y is [[a,:.],:y'] => +; a=x => deleteAssoc(x,y') +; [first y,:deleteAssoc(x,y')] +; y + +(DEFUN |deleteAssoc| (|x| |y|) + (PROG (|ISTMP#1| |a| |y'|) + (RETURN + (COND + ((AND + (PAIRP |y|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |y|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN (SPADLET |a| (QCAR |ISTMP#1|)) (QUOTE T)))) + (PROGN (SPADLET |y'| (QCDR |y|)) (QUOTE T))) + (COND + ((BOOT-EQUAL |a| |x|) (|deleteAssoc| |x| |y'|)) + ((QUOTE T) (CONS (CAR |y|) (|deleteAssoc| |x| |y'|))))) + ((QUOTE T) |y|))))) + +;deleteAssocWOC(x,y) == +; null y => y +; [[a,:.],:t]:= y +; x=a => t +; (fn(x,y);y) where fn(x,y is [h,:t]) == +; t is [[a,:.],:t1] => +; x=a => RPLACD(y,t1) +; fn(x,t) +; nil + +(DEFUN |deleteAssocWOC,fn| (|x| |y|) + (PROG (|h| |t| |ISTMP#1| |a| |t1|) + (RETURN + (SEQ + (PROGN + (SPADLET |h| (CAR |y|)) + (SPADLET |t| (CDR |y|)) + |y| + (SEQ + (IF + (AND (PAIRP |t|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |t|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN (SPADLET |a| (QCAR |ISTMP#1|)) (QUOTE T)))) + (PROGN (SPADLET |t1| (QCDR |t|)) (QUOTE T))) + (EXIT + (SEQ + (IF (BOOT-EQUAL |x| |a|) (EXIT (RPLACD |y| |t1|))) + (EXIT (|deleteAssocWOC,fn| |x| |t|))))) + (EXIT NIL))))))) + +(DEFUN |deleteAssocWOC| (|x| |y|) + (PROG (|a| |t|) + (RETURN + (COND + ((NULL |y|) |y|) + ((QUOTE T) + (SPADLET |a| (CAAR |y|)) + (SPADLET |t| (CDR |y|)) + (COND + ((BOOT-EQUAL |x| |a|) |t|) + ((QUOTE T) (|deleteAssocWOC,fn| |x| |y|) |y|))))))) + +;insertWOC(x,y) == +; null y => [x] +; (fn(x,y); y) where fn(x,y is [h,:t]) == +; x=h => nil +; null t => +; RPLACD(y,[h,:t]) +; RPLACA(y,x) +; fn(x,t) + +(DEFUN |insertWOC,fn| (|x| |y|) + (PROG (|h| |t|) + (RETURN + (SEQ + (PROGN + (SPADLET |h| (CAR |y|)) + (SPADLET |t| (CDR |y|)) + |y| + (SEQ + (IF (BOOT-EQUAL |x| |h|) (EXIT NIL)) + (IF (NULL |t|) + (EXIT (SEQ (RPLACD |y| (CONS |h| |t|)) (EXIT (RPLACA |y| |x|))))) + (EXIT (|insertWOC,fn| |x| |t|)))))))) + +(DEFUN |insertWOC| (|x| |y|) + (COND + ((NULL |y|) (CONS |x| NIL)) + ((QUOTE T) (|insertWOC,fn| |x| |y|) |y|))) + +;fillerSpaces(n,:charPart) == +; n <= 0 => '"" +; MAKE_-FULL_-CVEC(n,IFCAR charPart or '" ") + +(DEFUN |fillerSpaces| (&REST #0=#:G1406 &AUX |charPart| |n|) + (DSETQ (|n| . |charPart|) #0#) + (COND + ((<= |n| 0) (MAKESTRING "")) + ((QUOTE T) (MAKE-FULL-CVEC |n| (OR (IFCAR |charPart|) (MAKESTRING " ")))))) + +;centerString(text,width,fillchar) == +; wid := entryWidth text +; wid >= width => text +; f := DIVIDE(width - wid,2) +; fill1 := "" +; for i in 1..(f.0) repeat +; fill1 := STRCONC(fillchar,fill1) +; fill2:= fill1 +; if f.1 ^= 0 then fill1 := STRCONC(fillchar,fill1) +; [fill1,text,fill2] + +(DEFUN |centerString| (|text| |width| |fillchar|) + (PROG (|wid| |f| |fill2| |fill1|) + (RETURN + (SEQ + (PROGN + (SPADLET |wid| (|entryWidth| |text|)) + (COND + ((>= |wid| |width|) |text|) + ((QUOTE T) + (SPADLET |f| (DIVIDE (SPADDIFFERENCE |width| |wid|) 2)) + (SPADLET |fill1| (QUOTE ||)) + (DO ((#0=#:G1407 (ELT |f| 0)) (|i| 1 (QSADD1 |i|))) + ((QSGREATERP |i| #0#) NIL) + (SEQ (EXIT (SPADLET |fill1| (STRCONC |fillchar| |fill1|))))) + (SPADLET |fill2| |fill1|) + (COND + ((NEQUAL (ELT |f| 1) 0) + (SPADLET |fill1| (STRCONC |fillchar| |fill1|)))) + (CONS |fill1| (CONS |text| (CONS |fill2| NIL)))))))))) + +;stringPrefix?(pref,str) == +; -- sees if the first #pref letters of str are pref +; -- replaces STRINGPREFIXP +; null (STRINGP(pref) and STRINGP(str)) => NIL +; (lp := QCSIZE pref) = 0 => true +; lp > QCSIZE str => NIL +; ok := true +; i := 0 +; while ok and (i < lp) repeat +; not EQ(SCHAR(pref,i),SCHAR(str,i)) => ok := NIL +; i := i + 1 +; ok + +(DEFUN |stringPrefix?| (|pref| |str|) + (PROG (|lp| |ok| |i|) + (RETURN + (SEQ + (COND + ((NULL (AND (STRINGP |pref|) (STRINGP |str|))) NIL) + ((EQL (SPADLET |lp| (QCSIZE |pref|)) 0) (QUOTE T)) + ((> |lp| (QCSIZE |str|)) NIL) + ((QUOTE T) + (SPADLET |ok| (QUOTE T)) + (SPADLET |i| 0) + (DO () + ((NULL (AND |ok| (> |lp| |i|))) + NIL) + (SEQ + (EXIT + (COND + ((NULL (EQ (SCHAR |pref| |i|) (SCHAR |str| |i|))) (SPADLET |ok| NIL)) + ((QUOTE T) (SPADLET |i| (PLUS |i| 1))))))) + |ok|)))))) + +;stringChar2Integer(str,pos) == +; -- replaces GETSTRINGDIGIT in UT LISP +; -- returns small integer represented by character in position pos +; -- in string str. Returns NIL if not a digit or other error. +; if IDENTP str then str := PNAME str +; null (STRINGP(str) and +; INTEGERP(pos) and (pos >= 0) and (pos < QCSIZE(str))) => NIL +; not DIGITP(d := SCHAR(str,pos)) => NIL +; DIG2FIX d + +(DEFUN |stringChar2Integer| (|str| |pos|) + (PROG (|d|) + (RETURN + (PROGN + (COND ((IDENTP |str|) (SPADLET |str| (PNAME |str|)))) + (COND + ((NULL + (AND (STRINGP |str|) + (INTEGERP |pos|) + (>= |pos| 0) + (> (QCSIZE |str|) |pos|))) + NIL) + ((NULL (DIGITP (SPADLET |d| (SCHAR |str| |pos|)))) NIL) + ((QUOTE T) (DIG2FIX |d|))))))) + +;dropLeadingBlanks str == +; str := object2String str +; l := QCSIZE str +; nb := NIL +; i := 0 +; while (i < l) and not nb repeat +; if SCHAR(str,i) ^= " " then nb := i +; else i := i + 1 +; nb = 0 => str +; nb => SUBSTRING(str,nb,NIL) +; '"" + +(DEFUN |dropLeadingBlanks| (|str|) + (PROG (|l| |nb| |i|) + (RETURN + (SEQ + (PROGN + (SPADLET |str| (|object2String| |str|)) + (SPADLET |l| (QCSIZE |str|)) + (SPADLET |nb| NIL) + (SPADLET |i| 0) + (DO () + ((NULL (AND (> |l| |i|) (NULL |nb|))) + NIL) + (SEQ + (EXIT + (COND + ((NEQUAL (SCHAR |str| |i|) (QUOTE | |)) (SPADLET |nb| |i|)) + ((QUOTE T) (SPADLET |i| (PLUS |i| 1))))))) + (COND + ((EQL |nb| 0) |str|) + (|nb| (SUBSTRING |str| |nb| NIL)) + ((QUOTE T) (MAKESTRING "")))))))) + +;concat(:l) == concatList l + +(DEFUN |concat| (&REST #0=#:G1408 &AUX |l|) + (DSETQ |l| #0#) + (|concatList| |l|)) + +;concatList [x,:y] == +; null y => x +; null x => concatList y +; concat1(x,concatList y) + +(DEFUN |concatList| (#0=#:G1409) + (PROG (|x| |y|) + (RETURN + (PROGN + (SPADLET |x| (CAR #0#)) + (SPADLET |y| (CDR #0#)) + (COND + ((NULL |y|) |x|) + ((NULL |x|) (|concatList| |y|)) + ((QUOTE T) (|concat1| |x| (|concatList| |y|)))))))) + +;concat1(x,y) == +; null x => y +; atom x => (null y => x; atom y => [x,y]; [x,:y]) +; null y => x +; atom y => [:x,y] +; [:x,:y] + +(DEFUN |concat1| (|x| |y|) + (COND + ((NULL |x|) |y|) + ((ATOM |x|) + (COND + ((NULL |y|) |x|) + ((ATOM |y|) (CONS |x| (CONS |y| NIL))) + ((QUOTE T) (CONS |x| |y|)))) + ((NULL |y|) |x|) + ((ATOM |y|) (APPEND |x| (CONS |y| NIL))) + ((QUOTE T) (APPEND |x| |y|)))) + +;ravel a == a + +(DEFUN |ravel| (|a|) |a|) + +;reshape(a,b) == a + +(DEFUN |reshape| (|a| |b|) |a|) + +;boolODDP x == ODDP x + +(DEFUN |boolODDP| (|x|) (ODDP |x|)) + +;freeOfSharpVars x == +; atom x => not isSharpVarWithNum x +; freeOfSharpVars first x and freeOfSharpVars rest x + +(DEFUN |freeOfSharpVars| (|x|) + (COND + ((ATOM |x|) (NULL (|isSharpVarWithNum| |x|))) + ((QUOTE T) + (AND (|freeOfSharpVars| (CAR |x|)) (|freeOfSharpVars| (CDR |x|)))))) + +;listOfSharpVars x == +; atom x => (isSharpVarWithNum x => LIST x; nil) +; setUnion(listOfSharpVars first x,listOfSharpVars rest x) + +(DEFUN |listOfSharpVars| (|x|) + (COND + ((ATOM |x|) (COND ((|isSharpVarWithNum| |x|) (LIST |x|)) ((QUOTE T) NIL))) + ((QUOTE T) + (|union| (|listOfSharpVars| (CAR |x|)) (|listOfSharpVars| (CDR |x|)))))) + +;listOfPatternIds x == +; isPatternVar x => [x] +; atom x => nil +; x is ['QUOTE,:.] => nil +; UNIONQ(listOfPatternIds first x,listOfPatternIds rest x) + +(DEFUN |listOfPatternIds| (|x|) + (COND + ((|isPatternVar| |x|) (CONS |x| NIL)) + ((ATOM |x|) NIL) + ((AND (PAIRP |x|) (EQ (QCAR |x|) (QUOTE QUOTE))) NIL) + ((QUOTE T) + (UNIONQ (|listOfPatternIds| (CAR |x|)) (|listOfPatternIds| (CDR |x|)))))) + +;isPatternVar v == +; -- a pattern variable consists of a star followed by a star or digit(s) +; IDENTP(v) and MEMQ(v,'(_*_* _*1 _*2 _*3 _*4 _*5 _*6 _*7 _*8 _*9 _*10 +; _*11 _*12 _*13 _*14 _*15 _*16 _*17 _*18 _*19 _*20)) and true + +(DEFUN |isPatternVar| (|v|) + (AND + (IDENTP |v|) + (MEMQ |v| (QUOTE (** *1 *2 *3 *4 *5 *6 *7 *8 *9 *10 *11 *12 *13 *14 *15 + *16 *17 *18 *19 *20))) + (QUOTE T))) + +;removeZeroOne x == +; -- replace all occurrences of (Zero) and (One) with +; -- 0 and 1 +; x = $Zero => 0 +; x = $One => 1 +; atom x => x +; [removeZeroOne first x,:removeZeroOne rest x] + +(DEFUN |removeZeroOne| (|x|) + (COND + ((BOOT-EQUAL |x| |$Zero|) 0) + ((BOOT-EQUAL |x| |$One|) 1) + ((ATOM |x|) |x|) + ((QUOTE T) (CONS (|removeZeroOne| (CAR |x|)) (|removeZeroOne| (CDR |x|)))))) + +;removeZeroOneDestructively t == +; -- replace all occurrences of (Zero) and (One) with +; -- 0 and 1 destructively +; t = $Zero => 0 +; t = $One => 1 +; atom t => t +; RPLNODE(t,removeZeroOneDestructively first t, +; removeZeroOneDestructively rest t) + +(DEFUN |removeZeroOneDestructively| (|t|) + (COND + ((BOOT-EQUAL |t| |$Zero|) 0) + ((BOOT-EQUAL |t| |$One|) 1) + ((ATOM |t|) |t|) + ((QUOTE T) + (RPLNODE |t| + (|removeZeroOneDestructively| (CAR |t|)) + (|removeZeroOneDestructively| (CDR |t|)))))) + +;flattenSexpr s == +; null s => s +; ATOM s => s +; [f,:r] := s +; ATOM f => [f,:flattenSexpr r] +; [:flattenSexpr f,:flattenSexpr r] + +(DEFUN |flattenSexpr| (|s|) + (PROG (|f| |r|) + (RETURN + (COND + ((NULL |s|) |s|) + ((ATOM |s|) |s|) + ((QUOTE T) + (SPADLET |f| (CAR |s|)) + (SPADLET |r| (CDR |s|)) + (COND + ((ATOM |f|) (CONS |f| (|flattenSexpr| |r|))) + ((QUOTE T) (APPEND (|flattenSexpr| |f|) (|flattenSexpr| |r|))))))))) + +;isLowerCaseLetter c == charRangeTest CHAR2NUM c + +(DEFUN |isLowerCaseLetter| (|c|) (|charRangeTest| (CHAR2NUM |c|))) + +;isUpperCaseLetter c == charRangeTest QSDIFFERENCE(CHAR2NUM c,64) + +(DEFUN |isUpperCaseLetter| (|c|) + (|charRangeTest| (QSDIFFERENCE (CHAR2NUM |c|) 64))) + +;isLetter c == +; n:= CHAR2NUM c +; charRangeTest n or charRangeTest QSDIFFERENCE(CHAR2NUM c,64) + +(DEFUN |isLetter| (|c|) + (PROG (|n|) + (RETURN + (PROGN + (SPADLET |n| (CHAR2NUM |c|)) + (OR + (|charRangeTest| |n|) + (|charRangeTest| (QSDIFFERENCE (CHAR2NUM |c|) 64))))))) + +;charRangeTest n == +; QSLESSP(153,n) => +; QSLESSP(169,n) => false +; QSLESSP(161,n) => true +; false +; QSLESSP(128,n) => +; QSLESSP(144,n) => true +; QSLESSP(138,n) => false +; true +; false + +(DEFUN |charRangeTest| (|n|) + (COND + ((QSLESSP 153 |n|) + (COND + ((QSLESSP 169 |n|) NIL) + ((QSLESSP 161 |n|) (QUOTE T)) + ((QUOTE T) NIL))) + ((QSLESSP 128 |n|) + (COND + ((QSLESSP 144 |n|) (QUOTE T)) + ((QSLESSP 138 |n|) NIL) + ((QUOTE T) (QUOTE T)))) + ((QUOTE T) NIL))) + +;update() == +; OBEY +; STRCONC('"SPADEDIT ",STRINGIMAGE _/VERSION,'" ",STRINGIMAGE _/WSNAME,'" A") +; _/UPDATE() + +(DEFUN |update| NIL + (PROGN + (OBEY + (STRCONC + "SPADEDIT " (STRINGIMAGE /VERSION) " " (STRINGIMAGE /WSNAME) " A")) + (/UPDATE))) + +;listSort(pred,list,:optional) == +; NOT functionp pred => error "listSort: first arg must be a function" +; NOT LISTP list => error "listSort: second argument must be a list" +; NULL optional => mergeSort(pred,function Identity,list,LENGTH list) +; key := CAR optional +; NOT functionp key => error "listSort: last arg must be a function" +; mergeSort(pred,key,list,LENGTH list) + +(DEFUN |listSort| (&REST #0=#:G1410 &AUX |optional| LIST |pred|) + (DSETQ (|pred| LIST . |optional|) #0#) + (PROG (|key|) + (RETURN + (COND + ((NULL (|functionp| |pred|)) + (|error| (QUOTE |listSort: first arg must be a function|))) + ((NULL (LISTP LIST)) + (|error| (QUOTE |listSort: second argument must be a list|))) + ((NULL |optional|) + (|mergeSort| |pred| (|function| |Identity|) LIST (LENGTH LIST))) + ((QUOTE T) + (SPADLET |key| (CAR |optional|)) + (COND + ((NULL (|functionp| |key|)) + (|error| (QUOTE |listSort: last arg must be a function|))) + ((QUOTE T) (|mergeSort| |pred| |key| LIST (LENGTH LIST))))))))) + +;MSORT list == listSort(function GLESSEQP, COPY_-LIST list) + +(DEFUN MSORT (LIST) + (|listSort| (|function| GLESSEQP) (COPY-LIST LIST))) + +;NMSORT list == listSort(function GLESSEQP, list) + +(DEFUN NMSORT (LIST) (|listSort| (|function| GLESSEQP) LIST)) + +;orderList l == listSort(function _?ORDER, COPY_-LIST l) + +(DEFUN |orderList| (|l|) (|listSort| (|function| ?ORDER) (COPY-LIST |l|))) + +;mergeInPlace(f,g,p,q) == +; if NULL p then return p +; if NULL q then return q +; if FUNCALL(f,FUNCALL(g, QCAR p),FUNCALL(g, QCAR q)) +; then (r := t := p; p := QCDR p) +; else (r := t := q; q := QCDR q) +; while not NULL p and not NULL q repeat +; if FUNCALL(f,FUNCALL(g,QCAR p),FUNCALL(g,QCAR q)) +; then (QRPLACD(t,p); t := p; p := QCDR p) +; else (QRPLACD(t,q); t := q; q := QCDR q) +; if NULL p then QRPLACD(t,q) else QRPLACD(t,p) +; r + +(DEFUN |mergeInPlace| (|f| |g| |p| |q|) + (PROG (|r| |t|) + (RETURN + (SEQ + (PROGN + (COND ((NULL |p|) (RETURN |p|))) + (COND ((NULL |q|) (RETURN |q|))) + (COND + ((FUNCALL |f| (FUNCALL |g| (QCAR |p|)) (FUNCALL |g| (QCAR |q|))) + (SPADLET |r| (SPADLET |t| |p|)) (SPADLET |p| (QCDR |p|))) + ((QUOTE T) + (SPADLET |r| (SPADLET |t| |q|)) (SPADLET |q| (QCDR |q|)))) + (DO () + ((NULL (AND (NULL (NULL |p|)) (NULL (NULL |q|)))) NIL) + (SEQ + (EXIT + (COND + ((FUNCALL |f| (FUNCALL |g| (QCAR |p|)) (FUNCALL |g| (QCAR |q|))) + (QRPLACD |t| |p|) + (SPADLET |t| |p|) + (SPADLET |p| (QCDR |p|))) + ((QUOTE T) + (QRPLACD |t| |q|) + (SPADLET |t| |q|) + (SPADLET |q| (QCDR |q|))))))) + (COND + ((NULL |p|) (QRPLACD |t| |q|)) + ((QUOTE T) (QRPLACD |t| |p|))) + |r|))))) + +;mergeSort(f,g,p,n) == +; if EQ(n,2) and FUNCALL(f,FUNCALL(g,QCADR p),FUNCALL(g,QCAR p)) then +; t := p +; p := QCDR p +; QRPLACD(p,t) +; QRPLACD(t,NIL) +; if QSLESSP(n,3) then return p +; -- split the list p into p and q of equal length +; l := QSQUOTIENT(n,2) +; t := p +; for i in 1..l-1 repeat t := QCDR t +; q := rest t +; QRPLACD(t,NIL) +; p := mergeSort(f,g,p,l) +; q := mergeSort(f,g,q,QSDIFFERENCE(n,l)) +; mergeInPlace(f,g,p,q) + +(DEFUN |mergeSort| (|f| |g| |p| |n|) + (PROG (|l| |t| |q|) + (RETURN + (SEQ + (PROGN + (COND + ((AND + (EQ |n| 2) + (FUNCALL |f| (FUNCALL |g| (QCADR |p|)) (FUNCALL |g| (QCAR |p|)))) + (SPADLET |t| |p|) + (SPADLET |p| (QCDR |p|)) + (QRPLACD |p| |t|) + (QRPLACD |t| NIL))) + (COND ((QSLESSP |n| 3) (RETURN |p|))) + (SPADLET |l| (QSQUOTIENT |n| 2)) + (SPADLET |t| |p|) + (DO ((#0=#:G1411 (SPADDIFFERENCE |l| 1)) (|i| 1 (QSADD1 |i|))) + ((QSGREATERP |i| #0#) NIL) + (SEQ (EXIT (SPADLET |t| (QCDR |t|))))) + (SPADLET |q| (CDR |t|)) + (QRPLACD |t| NIL) + (SPADLET |p| (|mergeSort| |f| |g| |p| |l|)) + (SPADLET |q| (|mergeSort| |f| |g| |q| (QSDIFFERENCE |n| |l|))) + (|mergeInPlace| |f| |g| |p| |q|)))))) + +;spadThrow() == +; if $interpOnly and $mapName then +; putHist($mapName,'localModemap, nil, $e) +; THROW("SPAD__READER",nil) + +(DEFUN |spadThrow| () + (PROGN + (COND + ((AND |$interpOnly| |$mapName|) + (|putHist| |$mapName| (QUOTE |localModemap|) NIL |$e|))) + (THROW (QUOTE SPAD_READER) NIL))) + +;spadThrowBrightly x == +; sayBrightly x +; spadThrow() + +(DEFUN |spadThrowBrightly| (|x|) (PROGN (|sayBrightly| |x|) (|spadThrow|))) + +;formatUnabbreviatedSig sig == +; null sig => ["() -> ()"] +; [target,:args] := sig +; target := formatUnabbreviated target +; null args => ['"() -> ",:target] +; null rest args => [:formatUnabbreviated QCAR args,'" -> ",:target] +; args := formatUnabbreviatedTuple args +; ['"(",:args,'") -> ",:target] + +(DEFUN |formatUnabbreviatedSig| (|sig|) + (PROG (|target| |args|) + (RETURN + (COND + ((NULL |sig|) (CONS (QUOTE |() -> ()|) NIL)) + ((QUOTE T) + (SPADLET |target| (CAR |sig|)) + (SPADLET |args| (CDR |sig|)) + (SPADLET |target| (|formatUnabbreviated| |target|)) + (COND + ((NULL |args|) (CONS (MAKESTRING "() -> ") |target|)) + ((NULL (CDR |args|)) + (APPEND + (|formatUnabbreviated| (QCAR |args|)) + (CONS (MAKESTRING " -> ") |target|))) + ((QUOTE T) + (SPADLET |args| (|formatUnabbreviatedTuple| |args|)) + (CONS + (MAKESTRING "(") + (APPEND |args| (CONS (MAKESTRING ") -> ") |target|)))))))))) + +;formatUnabbreviatedTuple t == +; -- t is a list of types +; null t => t +; atom t => [t] +; t0 := formatUnabbreviated QCAR t +; null rest t => t0 +; [:t0,'",",:formatUnabbreviatedTuple QCDR t] + +;;; *** |formatUnabbreviatedTuple| REDEFINED + +(DEFUN |formatUnabbreviatedTuple| (|t|) + (PROG (|t0|) + (RETURN + (COND + ((NULL |t|) |t|) + ((ATOM |t|) (CONS |t| NIL)) + ((QUOTE T) + (SPADLET |t0| (|formatUnabbreviated| (QCAR |t|))) + (COND + ((NULL (CDR |t|)) |t0|) + ((QUOTE T) + (APPEND + |t0| + (CONS "," (|formatUnabbreviatedTuple| (QCDR |t|))))))))))) + +;formatUnabbreviated t == +; atom t => +; [t] +; null t => +; ['"()"] +; t is [p,sel,arg] and p in '(_: ":") => +; [sel,'": ",:formatUnabbreviated arg] +; t is ['Union,:args] => +; ['Union,'"(",:formatUnabbreviatedTuple args,'")"] +; t is ['Mapping,:args] => +; formatUnabbreviatedSig args +; t is ['Record,:args] => +; ['Record,'"(",:formatUnabbreviatedTuple args,'")"] +; t is [arg] => +; t +; t is [arg,arg1] => +; [arg,'" ",:formatUnabbreviated arg1] +; t is [arg,:args] => +; [arg,'"(",:formatUnabbreviatedTuple args,'")"] +; t + +(DEFUN |formatUnabbreviated| (|t|) + (PROG (|p| |sel| |ISTMP#2| |ISTMP#1| |arg1| |arg| |args|) + (RETURN + (COND + ((ATOM |t|) (CONS |t| NIL)) + ((NULL |t|) (CONS (MAKESTRING "()") NIL)) + ((AND + (PAIRP |t|) + (PROGN + (SPADLET |p| (QCAR |t|)) + (SPADLET |ISTMP#1| (QCDR |t|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |sel| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |arg| (QCAR |ISTMP#2|)) (QUOTE T)))))) + (|member| |p| (QUOTE (|:| ":")))) + (CONS |sel| (CONS (MAKESTRING ": ") (|formatUnabbreviated| |arg|)))) + ((AND (PAIRP |t|) + (EQ (QCAR |t|) (QUOTE |Union|)) + (PROGN (SPADLET |args| (QCDR |t|)) (QUOTE T))) + (CONS + (QUOTE |Union|) + (CONS "(" (APPEND (|formatUnabbreviatedTuple| |args|) (CONS ")" NIL))))) + ((AND (PAIRP |t|) + (EQ (QCAR |t|) (QUOTE |Mapping|)) + (PROGN (SPADLET |args| (QCDR |t|)) (QUOTE T))) + (|formatUnabbreviatedSig| |args|)) + ((AND (PAIRP |t|) + (EQ (QCAR |t|) (QUOTE |Record|)) + (PROGN (SPADLET |args| (QCDR |t|)) (QUOTE T))) + (CONS + (QUOTE |Record|) + (CONS "(" (APPEND (|formatUnabbreviatedTuple| |args|) (CONS ")" NIL))))) + ((AND (PAIRP |t|) + (EQ (QCDR |t|) NIL) + (PROGN (SPADLET |arg| (QCAR |t|)) (QUOTE T))) + |t|) + ((AND (PAIRP |t|) + (PROGN + (SPADLET |arg| (QCAR |t|)) + (SPADLET |ISTMP#1| (QCDR |t|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |arg1| (QCAR |ISTMP#1|)) (QUOTE T))))) + (CONS |arg| (CONS (MAKESTRING " ") (|formatUnabbreviated| |arg1|)))) + ((AND (PAIRP |t|) + (PROGN + (SPADLET |arg| (QCAR |t|)) + (SPADLET |args| (QCDR |t|)) + (QUOTE T))) + (CONS + |arg| + (CONS "(" (APPEND (|formatUnabbreviatedTuple| |args|) (CONS ")" NIL))))) + ((QUOTE T) |t|))))) + +;sublisNQ(al,e) == +; atom al => e +; fn(al,e) where fn(al,e) == +; atom e => +; for x in al repeat +; EQ(first x,e) => return (e := rest x) +; e +; EQ(a := first e,'QUOTE) => e +; u := fn(al,a) +; v := fn(al,rest e) +; EQ(a,u) and EQ(rest e,v) => e +; [u,:v] + +(DEFUN |sublisNQ,fn| (|al| |e|) + (PROG (|a| |u| |v|) + (RETURN + (SEQ + (IF (ATOM |e|) + (EXIT + (SEQ + (DO ((#0=#:G1412 |al| (CDR #0#)) (|x| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |x| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (IF (EQ (CAR |x|) |e|) (EXIT (RETURN (SPADLET |e| (CDR |x|)))))))) + (EXIT |e|)))) + (IF (EQ (SPADLET |a| (CAR |e|)) (QUOTE QUOTE)) (EXIT |e|)) + (SPADLET |u| (|sublisNQ,fn| |al| |a|)) + (SPADLET |v| (|sublisNQ,fn| |al| (CDR |e|))) + (IF (AND (EQ |a| |u|) (EQ (CDR |e|) |v|)) (EXIT |e|)) + (EXIT (CONS |u| |v|)))))) + +(DEFUN |sublisNQ| (|al| |e|) + (COND + ((ATOM |al|) |e|) + ((QUOTE T) (|sublisNQ,fn| |al| |e|)))) + +;str2Outform s == +; parse := ncParseFromString s or systemError '"String for TeX will not parse" +; parse2Outform parse + +(DEFUN |str2Outform| (|s|) + (PROG (|parse|) + (RETURN + (PROGN + (SPADLET |parse| + (OR (|ncParseFromString| |s|) + (|systemError| (MAKESTRING "String for TeX will not parse")))) + (|parse2Outform| |parse|))))) + +;parse2Outform x == +; x is [op,:argl] => +; nargl := [parse2Outform y for y in argl] +; op = 'construct => ['BRACKET,['ARGLST,:[parse2Outform y for y in argl]]] +; op = 'brace and nargl is [[BRACKET,:r]] => ['BRACE,:r] +; [op,:nargl] +; x + +(DEFUN |parse2Outform| (|x|) + (PROG (|op| |argl| |nargl| |ISTMP#1| BRACKET |r|) + (RETURN + (SEQ + (COND + ((AND (PAIRP |x|) + (PROGN + (SPADLET |op| (QCAR |x|)) + (SPADLET |argl| (QCDR |x|)) + (QUOTE T))) + (SPADLET |nargl| + (PROG (#0=#:G1413) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G1414 |argl| (CDR #1#)) (|y| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |y| (CAR #1#)) NIL)) (NREVERSE0 #0#)) + (SEQ (EXIT (SETQ #0# (CONS (|parse2Outform| |y|) #0#)))))))) + (COND + ((BOOT-EQUAL |op| (QUOTE |construct|)) + (CONS + (QUOTE BRACKET) + (CONS + (CONS + (QUOTE ARGLST) + (PROG (#2=#:G1415) + (SPADLET #2# NIL) + (RETURN + (DO ((#3=#:G1416 |argl| (CDR #3#)) (|y| NIL)) + ((OR (ATOM #3#) (PROGN (SETQ |y| (CAR #3#)) NIL)) + (NREVERSE0 #2#)) + (SEQ (EXIT (SETQ #2# (CONS (|parse2Outform| |y|) #2#)))))))) + NIL))) + ((AND + (BOOT-EQUAL |op| (QUOTE |brace|)) + (PAIRP |nargl|) + (EQ (QCDR |nargl|) NIL) + (PROGN + (SPADLET |ISTMP#1| (QCAR |nargl|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET BRACKET (QCAR |ISTMP#1|)) + (SPADLET |r| (QCDR |ISTMP#1|)) + (QUOTE T))))) + (CONS (QUOTE BRACE) |r|)) + ((QUOTE T) (CONS |op| |nargl|)))) + ((QUOTE T) |x|)))))) + +;str2Tex s == +; outf := str2Outform s +; val := coerceInt(mkObj(wrap outf, '(OutputForm)), '(TexFormat)) +; val := objValUnwrap val +; CAR val.1 + +(DEFUN |str2Tex| (|s|) + (PROG (|outf| |val|) + (RETURN + (PROGN + (SPADLET |outf| (|str2Outform| |s|)) + (SPADLET |val| + (|coerceInt| + (|mkObj| (|wrap| |outf|) (QUOTE (|OutputForm|))) + (QUOTE (|TexFormat|)))) + (SPADLET |val| (|objValUnwrap| |val|)) + (CAR (ELT |val| 1)))))) + +;opOf x == +; atom x => x +; first x + +(DEFUN |opOf| (|x|) (COND ((ATOM |x|) |x|) ((QUOTE T) (CAR |x|)))) + +;getProplist(x,E) == +; not atom x => getProplist(first x,E) +; u:= search(x,E) => u +; --$InteractiveMode => nil +; --$InteractiveMode and (u:= search(x,$InteractiveFrame)) => u +; (pl:=search(x,$CategoryFrame)) => +; pl + +(DEFUN |getProplist| (|x| E) + (PROG (|u| |pl|) + (RETURN + (COND + ((NULL (ATOM |x|)) (|getProplist| (CAR |x|) E)) + ((SPADLET |u| (|search| |x| E)) |u|) + ((SPADLET |pl| (|search| |x| |$CategoryFrame|)) |pl|))))) + +;-- (pl:=PROPLIST x) => pl +;-- Above line commented out JHD/BMT 2.Aug.90 +;search(x,e is [curEnv,:tailEnv]) == +; searchCurrentEnv(x,curEnv) or searchTailEnv(x,tailEnv) + +(DEFUN |search| (|x| |e|) + (PROG (|curEnv| |tailEnv|) + (RETURN + (PROGN + (SPADLET |curEnv| (CAR |e|)) + (SPADLET |tailEnv| (CDR |e|)) + (OR (|searchCurrentEnv| |x| |curEnv|) (|searchTailEnv| |x| |tailEnv|)))))) + +;searchCurrentEnv(x,currentEnv) == +; for contour in currentEnv repeat +; if u:= ASSQ(x,contour) then return (signal:= u) +; KDR signal + +(DEFUN |searchCurrentEnv| (|x| |currentEnv|) + (PROG (|u| |signal|) + (RETURN + (SEQ + (PROGN + (DO ((#0=#:G1417 |currentEnv| (CDR #0#)) (|contour| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |contour| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (COND + ((SPADLET |u| (ASSQ |x| |contour|)) (RETURN (SPADLET |signal| |u|))) + ((QUOTE T) NIL))))) + (KDR |signal|)))))) + +;searchTailEnv(x,e) == +; for env in e repeat +; signal:= +; for contour in env repeat +; if (u:= ASSQ(x,contour)) and ASSQ("FLUID",u) then return (signal:= u) +; if signal then return signal +; KDR signal + +(DEFUN |searchTailEnv| (|x| |e|) + (PROG (|u| |signal|) + (RETURN + (SEQ + (PROGN + (DO ((#0=#:G1418 |e| (CDR #0#)) (|env| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |env| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (SPADLET |signal| + (PROGN + (DO ((#1=#:G1419 |env| (CDR #1#)) (|contour| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |contour| (CAR #1#)) NIL)) NIL) + (SEQ + (EXIT + (COND + ((AND + (SPADLET |u| (ASSQ |x| |contour|)) + (ASSQ (QUOTE FLUID) |u|)) + (RETURN (SPADLET |signal| |u|))) + ((QUOTE T) NIL))))) + (COND (|signal| (RETURN |signal|)) ((QUOTE T) NIL))))))) + (KDR |signal|)))))) + +;augProplist(proplist,prop,val) == +; $InteractiveMode => augProplistInteractive(proplist,prop,val) +; while (proplist is [[ =prop,:.],:proplist']) repeat proplist:= proplist' +; val=(u:= LASSOC(prop,proplist)) => proplist +; null val => +; null u => proplist +; DELLASOS(prop,proplist) +; [[prop,:val],:proplist] + +(DEFUN |augProplist| (|proplist| |prop| |val|) + (PROG (|ISTMP#1| |proplist'| |u|) + (RETURN + (SEQ + (COND + (|$InteractiveMode| (|augProplistInteractive| |proplist| |prop| |val|)) + ((QUOTE T) + (DO () + ((NULL + (AND (PAIRP |proplist|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |proplist|)) + (AND (PAIRP |ISTMP#1|) (EQUAL (QCAR |ISTMP#1|) |prop|))) + (PROGN (SPADLET |proplist'| (QCDR |proplist|)) (QUOTE T)))) + NIL) + (SEQ (EXIT (SPADLET |proplist| |proplist'|)))) + (COND + ((BOOT-EQUAL |val| (SPADLET |u| (LASSOC |prop| |proplist|))) |proplist|) + ((NULL |val|) + (COND + ((NULL |u|) |proplist|) + ((QUOTE T) (DELLASOS |prop| |proplist|)))) + ((QUOTE T) (CONS (CONS |prop| |val|) |proplist|))))))))) + +;augProplistOf(var,prop,val,e) == +; proplist:= getProplist(var,e) +; semchkProplist(var,proplist,prop,val) +; augProplist(proplist,prop,val) + +(DEFUN |augProplistOf| (|var| |prop| |val| |e|) + (PROG (|proplist|) + (RETURN + (PROGN + (SPADLET |proplist| (|getProplist| |var| |e|)) + (|semchkProplist| |var| |proplist| |prop| |val|) + (|augProplist| |proplist| |prop| |val|))))) + +;semchkProplist(x,proplist,prop,val) == +; prop="isLiteral" => +; LASSOC("value",proplist) or LASSOC("mode",proplist) => warnLiteral x +; MEMQ(prop,'(mode value)) => +; LASSOC("isLiteral",proplist) => warnLiteral x + +;;; *** |semchkProplist| REDEFINED + +(DEFUN |semchkProplist| (|x| |proplist| |prop| |val|) + (SEQ + (COND + ((BOOT-EQUAL |prop| (QUOTE |isLiteral|)) + (COND + ((OR + (LASSOC (QUOTE |value|) |proplist|) + (LASSOC (QUOTE |mode|) |proplist|)) + (EXIT (|warnLiteral| |x|))))) + ((MEMQ |prop| (QUOTE (|mode| |value|))) + (COND + ((LASSOC (QUOTE |isLiteral|) |proplist|) + (EXIT (|warnLiteral| |x|)))))))) + +;DEFPARAMETER($envHashTable,nil) + +(DEFPARAMETER |$envHashTable| NIL) + +;addBinding(var,proplist,e is [[curContour,:tailContour],:tailEnv]) == +; EQ(proplist,getProplist(var,e)) => e +; if $envHashTable then +; for u in proplist repeat +; HPUT($envHashTable,[var, CAR u],true) +; $InteractiveMode => addBindingInteractive(var,proplist,e) +; if curContour is [[ =var,:.],:.] then curContour:= rest curContour +; --Previous line should save some space +; [[[lx,:curContour],:tailContour],:tailEnv] where lx:= [var,:proplist] + +;;; *** |addBinding| REDEFINED + +(DEFUN |addBinding| (|var| |proplist| |e|) + (PROG (|tailContour| |tailEnv| |ISTMP#1| |curContour| |lx|) + (RETURN + (SEQ + (PROGN + (SPADLET |curContour| (CAAR |e|)) + (SPADLET |tailContour| (CDAR |e|)) + (SPADLET |tailEnv| (CDR |e|)) + (COND + ((EQ |proplist| (|getProplist| |var| |e|)) |e|) + ((QUOTE T) + (COND + (|$envHashTable| + (DO ((#0=#:G1420 |proplist| (CDR #0#)) (|u| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |u| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (HPUT |$envHashTable| + (CONS |var| (CONS (CAR |u|) NIL)) (QUOTE T))))))) + (COND + (|$InteractiveMode| (|addBindingInteractive| |var| |proplist| |e|)) + ((QUOTE T) + (COND + ((AND (PAIRP |curContour|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |curContour|)) + (AND (PAIRP |ISTMP#1|) (EQUAL (QCAR |ISTMP#1|) |var|)))) + (SPADLET |curContour| (CDR |curContour|)))) + (SPADLET |lx| (CONS |var| |proplist|)) + (CONS + (CONS (CONS |lx| |curContour|) |tailContour|) + |tailEnv|)))))))))) + +;position(x,l) == +; posn(x,l,0) where +; posn(x,l,n) == +; null l => -1 +; x=first l => n +; posn(x,rest l,n+1) + +(DEFUN |position,posn| (|x| |l| |n|) + (SEQ + (IF (NULL |l|) (EXIT (SPADDIFFERENCE 1))) + (IF (BOOT-EQUAL |x| (CAR |l|)) (EXIT |n|)) + (EXIT (|position,posn| |x| (CDR |l|) (PLUS |n| 1))))) + +(DEFUN |position| (|x| |l|) (|position,posn| |x| |l| 0)) + +;insert(x,y) == +; MEMBER(x,y) => y +; [x,:y] + +(DEFUN |insert| (|x| |y|) + (COND + ((|member| |x| |y|) |y|) + ((QUOTE T) (CONS |x| |y|)))) + +;after(u,v) == +; r:= u +; for x in u for y in v repeat r:= rest r +; r + +(DEFUN |after| (|u| |v|) + (PROG (|r|) + (RETURN + (SEQ + (PROGN + (SPADLET |r| |u|) + (DO ((#0=#:G1421 |u| (CDR #0#)) + (|x| NIL) + (#1=#:G1422 |v| (CDR #1#)) + (|y| NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ |x| (CAR #0#)) NIL) + (ATOM #1#) + (PROGN (SETQ |y| (CAR #1#)) NIL)) + NIL) + (SEQ (EXIT (SPADLET |r| (CDR |r|))))) + |r|))))) + +;$blank := char ('_ ) + +(SPADLET |$blank| (|char| (QUOTE | |))) + +;trimString s == +; leftTrim rightTrim s + +(DEFUN |trimString| (|s|) (|leftTrim| (|rightTrim| |s|))) + +;leftTrim s == +; k := MAXINDEX s +; k < 0 => s +; s.0 = $blank => +; for i in 0..k while s.i = $blank repeat (j := i) +; SUBSTRING(s,j + 1,nil) +; s + +(DEFUN |leftTrim| (|s|) + (PROG (|k| |j|) + (RETURN + (SEQ + (PROGN + (SPADLET |k| (MAXINDEX |s|)) + (COND + ((MINUSP |k|) |s|) + ((BOOT-EQUAL (ELT |s| 0) |$blank|) + (DO ((|i| 0 (QSADD1 |i|))) + ((OR (QSGREATERP |i| |k|) + (NULL (BOOT-EQUAL (ELT |s| |i|) |$blank|))) + NIL) + (SEQ (EXIT (SPADLET |j| |i|)))) + (SUBSTRING |s| (PLUS |j| 1) NIL)) + ((QUOTE T) |s|))))))) + +;rightTrim s == -- assumed a non-empty string +; k := MAXINDEX s +; k < 0 => s +; s.k = $blank => +; for i in k..0 by -1 while s.i = $blank repeat (j := i) +; SUBSTRING(s,0,j) +; s + +(DEFUN |rightTrim| (|s|) + (PROG (|k| |j|) + (RETURN + (SEQ + (PROGN + (SPADLET |k| (MAXINDEX |s|)) + (COND + ((MINUSP |k|) |s|) + ((BOOT-EQUAL (ELT |s| |k|) |$blank|) + (DO ((#0=#:G1423 (SPADDIFFERENCE 1)) (|i| |k| (+ |i| #0#))) + ((OR (IF (MINUSP #0#) (< |i| 0) (> |i| 0)) + (NULL (BOOT-EQUAL (ELT |s| |i|) |$blank|))) + NIL) + (SEQ (EXIT (SPADLET |j| |i|)))) + (SUBSTRING |s| 0 |j|)) + ((QUOTE T) |s|))))))) + +;pp x == +; PRETTYPRINT x +; x + +(DEFUN |pp| (|x|) (PROGN (PRETTYPRINT |x|) |x|)) + +;pr x == +; F_,PRINT_-ONE x +; nil + +(DEFUN |pr| (|x|) (PROGN (|F,PRINT-ONE| |x|) NIL)) + +;quickAnd(a,b) == +; a = true => b +; b = true => a +; a = false or b = false => false +; simpBool ['AND,a,b] + +(DEFUN |quickAnd| (|a| |b|) + (COND + ((BOOT-EQUAL |a| (QUOTE T)) |b|) + ((BOOT-EQUAL |b| (QUOTE T)) |a|) + ((OR (NULL |a|) (NULL |b|)) NIL) + ((QUOTE T) (|simpBool| (CONS (QUOTE AND) (CONS |a| (CONS |b| NIL))))))) + +;quickOr(a,b) == +; a = true or b = true => true +; b = false => a +; a = false => b +; simpCatPredicate simpBool ['OR,a,b] + +(DEFUN |quickOr| (|a| |b|) + (COND + ((OR (BOOT-EQUAL |a| (QUOTE T)) (BOOT-EQUAL |b| (QUOTE T))) (QUOTE T)) + ((NULL |b|) |a|) + ((NULL |a|) |b|) + ((QUOTE T) + (|simpCatPredicate| + (|simpBool| (CONS (QUOTE OR) (CONS |a| (CONS |b| NIL)))))))) + +;intern x == +; STRINGP x => +; DIGITP x.0 => string2Integer x +; INTERN x +; x + +(DEFUN |intern| (|x|) + (COND + ((STRINGP |x|) + (COND + ((DIGITP (ELT |x| 0)) (|string2Integer| |x|)) + ((QUOTE T) (INTERN |x|)))) + ((QUOTE T) |x|))) + +;isDomain a == +; PAIRP a and VECP(CAR a) and +; MEMBER(CAR(a).0, $domainTypeTokens) + +(DEFUN |isDomain| (|a|) + (AND + (PAIRP |a|) + (VECP (CAR |a|)) + (|member| (ELT (CAR |a|) 0) |$domainTypeTokens|))) + +;$htHash := MAKE_-HASH_-TABLE() + +(SPADLET |$htHash| (MAKE-HASH-TABLE)) + +;$glossHash := MAKE_-HASH_-TABLE() + +(SPADLET |$glossHash| (MAKE-HASH-TABLE)) + +;$lispHash := MAKE_-HASH_-TABLE() + +(SPADLET |$lispHash| (MAKE-HASH-TABLE)) + +;$sysHash := MAKE_-HASH_-TABLE() + +(SPADLET |$sysHash| (MAKE-HASH-TABLE)) + +;$htSystemCommands := '( +; (boot . development) clear display (fin . development) edit help +; frame history load quit read set show synonym system +; trace what ) + +(SPADLET |$htSystemCommands| + (QUOTE + ((|boot| . |development|) + |clear| + |display| + (|fin| . |development|) + |edit| + |help| + |frame| + |history| + |load| + |quit| + |read| + |set| + |show| + |synonym| + |system| + |trace| + |what|))) + +;$currentSysList := [opOf x for x in $htSystemCommands] --see ht-root + +(SPADLET |$currentSysList| + (COLLECT (IN |x| |$htSystemCommands|) (|opOf| |x|))) + +;$outStream := nil + +(SPADLET |$outStream| NIL) + +;$recheckingFlag := false --see transformAndRecheckComments + +(SPADLET |$recheckingFlag| NIL) + +;$exposeFlag := false --if true, messages go to $outStream + +(SPADLET |$exposeFlag| NIL) + +;$exposeFlagHeading := false --see htcheck.boot + +(SPADLET |$exposeFlagHeading| NIL) + +;$checkingXmptex? := false --see htcheck.boot + +(SPADLET |$checkingXmptex?| NIL) + +;$exposeDocHeading:= nil --see htcheck.boot + +(SPADLET |$exposeDocHeading| NIL) + +;$charPlus := char '_+ + +(SPADLET |$charPlus| (|char| (QUOTE +))) + +;$charBlank:= (char '_ ) + +(SPADLET |$charBlank| (|char| (QUOTE | |))) + +;$charLbrace:= char '_{ + +(SPADLET |$charLbrace| (|char| (QUOTE {))) + +;$charRbrace:= char '_} + +(SPADLET |$charRbrace| (|char| (QUOTE }))) + +;$charBack := char '_\ + +(SPADLET |$charBack| (|char| (QUOTE |\\|))) + +;$charDash := char '_- + +(SPADLET |$charDash| (|char| (QUOTE -))) + +;$charTab := CODE_-CHAR(9) + +(SPADLET |$charTab| (CODE-CHAR 9)) + +;$charNewline := CODE_-CHAR(10) + +(SPADLET |$charNewline| (CODE-CHAR 10)) + +;$charFauxNewline := CODE_-CHAR(25) + +(SPADLET |$charFauxNewline| (CODE-CHAR 25)) + +;$stringNewline := PNAME CODE_-CHAR(10) + +(SPADLET |$stringNewline| (PNAME (CODE-CHAR 10))) + +;$stringFauxNewline := PNAME CODE_-CHAR(25) + +(SPADLET |$stringFauxNewline| (PNAME (CODE-CHAR 25))) + +;$charExclusions := [char 'a, char 'A] + +(SPADLET |$charExclusions| + (CONS (|char| (QUOTE |a|)) (CONS (|char| (QUOTE A)) NIL))) + +;$charQuote := char '_' + +(SPADLET |$charQuote| (|char| (QUOTE |'|))) + +;$charSemiColon := char '_; + +(SPADLET |$charSemiColon| (|char| (QUOTE |;|))) + +;$charComma := char '_, + +(SPADLET |$charComma| (|char| (QUOTE |,|))) + +;$charPeriod := char '_. + +(SPADLET |$charPeriod| (|char| (INTERN "." "BOOT"))) + +;$checkPrenAlist := [[char '_(,:char '_)],[char '_{,:char '_}],[char '_[,:char '_]]] + +(SPADLET |$checkPrenAlist| + (CONS + (CONS (|char| (QUOTE |(|)) (|char| (QUOTE |)|))) + (CONS + (CONS (|char| (QUOTE {)) (|char| (QUOTE }))) + (CONS (CONS (|char| (QUOTE [)) (|char| (QUOTE ]))) NIL)))) + +;$charEscapeList:= [char '_%,char '_#,$charBack] + +(SPADLET |$charEscapeList| + (CONS (|char| (QUOTE %)) (CONS (|char| (QUOTE |#|)) (CONS |$charBack| NIL)))) + +;$charIdentifierEndings := [char '__, char '_!, char '_?] + +(SPADLET |$charIdentifierEndings| + (CONS + (|char| (QUOTE _)) + (CONS (|char| (QUOTE !)) (CONS (|char| (QUOTE ?)) NIL)))) + +;$charSplitList := [$charComma,$charPeriod,char '_[, char '_],$charLbrace, $charRbrace, char '_(, char '_), char '_$, char '_%] + +(SPADLET |$charSplitList| + (CONS + |$charComma| + (CONS + |$charPeriod| + (CONS + (|char| (QUOTE [)) + (CONS + (|char| (QUOTE ])) + (CONS + |$charLbrace| + (CONS + |$charRbrace| + (CONS + (|char| (QUOTE |(|)) + (CONS + (|char| (QUOTE |)|)) + (CONS + (|char| (QUOTE $)) + (CONS + (|char| (QUOTE %)) + NIL))))))))))) + +;$charDelimiters := [$charBlank, char '_(, char '_), $charBack] + +(SPADLET |$charDelimiters| + (CONS + |$charBlank| + (CONS + (|char| (QUOTE |(|)) + (CONS + (|char| (QUOTE |)|)) + (CONS + |$charBack| + NIL))))) + +;$HTspadmacros := '("\spadtype" "\spadcommand" "\spadop" "\spadfun" "\spadatt" "\spadsyscom" "\spad" "\s") + +(SPADLET |$HTspadmacros| + (QUOTE + ("\\spadtype" + "\\spadcommand" + "\\spadop" + "\\spadfun" + "\\spadatt" + "\\spadsyscom" + "\\spad" + "\\s"))) + +;$HTmacs := [ +; ['"\beginmenu",$charRbrace,'"menu",$charLbrace,'"\begin"], +; ['"\endmenu",$charRbrace,'"menu",$charLbrace,'"\end"], +; ['"\beginitems",$charRbrace,'"items",$charLbrace,'"\begin"], +; ['"\enditems",$charRbrace,'"items",$charLbrace,'"\end"], +; ['"\beginscroll",$charRbrace,'"scroll",$charLbrace,'"\begin"], +; ['"\endscroll",$charRbrace,'"scroll",$charLbrace,'"\end"]] + +(SPADLET |$HTmacs| + (CONS + (CONS + (MAKESTRING "\\beginmenu") + (CONS + |$charRbrace| + (CONS + (MAKESTRING "menu") + (CONS + |$charLbrace| + (CONS + (MAKESTRING "\\begin") + NIL))))) + (CONS + (CONS + (MAKESTRING "\\endmenu") + (CONS + |$charRbrace| + (CONS + (MAKESTRING "menu") + (CONS + |$charLbrace| + (CONS + (MAKESTRING "\\end") + NIL))))) + (CONS + (CONS + (MAKESTRING "\\beginitems") + (CONS + |$charRbrace| + (CONS + (MAKESTRING "items") + (CONS + |$charLbrace| + (CONS + (MAKESTRING "\\begin") + NIL))))) + (CONS + (CONS + (MAKESTRING "\\enditems") + (CONS + |$charRbrace| + (CONS + (MAKESTRING "items") + (CONS + |$charLbrace| + (CONS + (MAKESTRING "\\end") + NIL))))) + (CONS + (CONS + (MAKESTRING "\\beginscroll") + (CONS + |$charRbrace| + (CONS + (MAKESTRING "scroll") + (CONS + |$charLbrace| + (CONS + (MAKESTRING "\\begin") + NIL))))) + (CONS + (CONS + (MAKESTRING "\\endscroll") + (CONS + |$charRbrace| + (CONS + (MAKESTRING "scroll") + (CONS + |$charLbrace| + (CONS + (MAKESTRING "\\end") + NIL))))) + NIL))))))) + +;$HTlinks := '( +; "\downlink" +; "\menulink" +; "\menudownlink" +; "\menuwindowlink" +; "\menumemolink") + +(SPADLET |$HTlinks| + (QUOTE + ("\\downlink" + "\\menulink" + "\\menudownlink" + "\\menuwindowlink" + "\\menumemolink"))) + +;$HTlisplinks := '( +; "\lispdownlink" +; "\menulispdownlink" +; "\menulispwindowlink" +; "\menulispmemolink" +; "\lispwindowlink" +; "\lispmemolink") + +(SPADLET |$HTlisplinks| + (QUOTE + ("\\lispdownlink" + "\\menulispdownlink" + "\\menulispwindowlink" + "\\menulispmemolink" + "\\lispwindowlink" + "\\lispmemolink"))) + +;$beginEndList := '( +; "page" +; "items" +; "menu" +; "scroll" +; "verbatim" +; "detail") + +(SPADLET |$beginEndList| + (QUOTE ("page" "items" "menu" "scroll" "verbatim" "detail"))) + +;isDefaultPackageName x == (s := PNAME x).(MAXINDEX s) = char '_& + +(DEFUN |isDefaultPackageName| (|x|) + (PROG (|s|) + (RETURN + (BOOT-EQUAL (ELT (SPADLET |s| (PNAME |x|)) (MAXINDEX |s|)) + (|char| (QUOTE &)))))) + + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document}