From 0850ca5458cb09b2d04cec162558500e9a05cf4a Mon Sep 17 00:00:00 2001 From: dos-reis Date: Thu, 20 Sep 2007 14:50:49 +0000 Subject: Revert commits to the wrong tree. --- src/interp/g-util.boot.pamphlet | 663 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 663 insertions(+) create mode 100644 src/interp/g-util.boot.pamphlet (limited to 'src/interp/g-util.boot.pamphlet') diff --git a/src/interp/g-util.boot.pamphlet b/src/interp/g-util.boot.pamphlet new file mode 100644 index 00000000..05e262c8 --- /dev/null +++ b/src/interp/g-util.boot.pamphlet @@ -0,0 +1,663 @@ +\documentclass{article} +\usepackage{axiom} + +\title{\File{src/interp/g-util.boot} Pamphlet} +\author{The Axiom Team} + +\begin{document} + +\maketitle +\begin{abstract} +\end{abstract} + +\tableofcontents +\eject + +\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. + +@ +<<*>>= +<> + +)package "BOOT" + +--% Utility Functions of General Use + +ELEMN(x, n, d) == + null x => d + n = 1 => car x + ELEMN(cdr x, SUB1 n, d) + +PPtoFile(x, fname) == + stream := DEFIOSTREAM([['MODE, :'OUTPUT], ['FILE, :fname]], 80, 0) + PRETTYPRINT(x, stream) + SHUT stream + x + +-- Convert an arbitrary lisp object to canonical boolean. +bool x == + NULL NULL x + +--% Various lispy things + +Identity x == x + +length1? l == PAIRP l and not PAIRP QCDR l + +length2? l == PAIRP l and PAIRP (l := QCDR l) and not PAIRP QCDR l + +pairList(u,v) == [[x,:y] for x in u for y in v] + +-- GETALIST(alist,prop) == IFCDR assoc(prop,alist) +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 + +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 + +deleteLassoc(x,y) == + y is [[a,:.],:y'] => + EQ(x,a) => y' + [first y,:deleteLassoc(x,y')] + y + +--% association list functions + +deleteAssoc(x,y) == + y is [[a,:.],:y'] => + a=x => deleteAssoc(x,y') + [first y,:deleteAssoc(x,y')] + 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 + +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) + + + +--% Miscellaneous Functions for Working with Strings + +fillerSpaces(n,:charPart) == + n <= 0 => '"" + MAKE_-FULL_-CVEC(n,IFCAR charPart or '" ") + +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] + +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 + +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 + +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) + '"" + +concat(:l) == concatList l + +concatList [x,:y] == + null y => x + null x => concatList y + 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] + +--% BOOT ravel and reshape + +ravel a == a + +reshape(a,b) == a + +--% Some functions for algebra code + +boolODDP x == ODDP x + +--% Miscellaneous + +freeOfSharpVars x == + atom x => not isSharpVarWithNum x + freeOfSharpVars first x and freeOfSharpVars rest x + +listOfSharpVars x == + atom x => (isSharpVarWithNum x => LIST x; nil) + setUnion(listOfSharpVars first x,listOfSharpVars rest x) + +listOfPatternIds x == + isPatternVar x => [x] + atom x => nil + x is ['QUOTE,:.] => nil + UNIONQ(listOfPatternIds first x,listOfPatternIds rest 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 + +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] + +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) + +flattenSexpr s == + null s => s + ATOM s => s + [f,:r] := s + ATOM f => [f,:flattenSexpr r] + [:flattenSexpr f,:flattenSexpr r] + +isLowerCaseLetter c == charRangeTest CHAR2NUM c + +isUpperCaseLetter c == charRangeTest QSDIFFERENCE(CHAR2NUM c,64) + +isLetter c == + n:= CHAR2NUM c + charRangeTest n or 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 + +update() == + OBEY + STRCONC('"SPADEDIT ",STRINGIMAGE _/VERSION,'" ",STRINGIMAGE _/WSNAME,'" A") + _/UPDATE() + +--% Inplace Merge Sort for Lists +-- MBM April/88 + +-- listSort(pred,list) or 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 + +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) + +-- non-destructive merge sort using NOT GGREATERP as predicate +MSORT list == listSort(function GLESSEQP, COPY_-LIST list) + +-- destructive merge sort using NOT GGREATERP as predicate +NMSORT list == listSort(function GLESSEQP, list) + +-- non-destructive merge sort using ?ORDER as predicate +orderList l == listSort(function _?ORDER, COPY_-LIST l) + +-- dummy defn until clean-up +-- order l == orderList l + +mergeInPlace(f,g,p,q) == + -- merge the two sorted lists p and 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 + +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) + +--% Throwing with glorious highlighting (maybe) + +spadThrow() == + if $interpOnly and $mapName then + putHist($mapName,'localModemap, nil, $e) + THROW("SPAD__READER",nil) + +spadThrowBrightly x == + sayBrightly x + spadThrow() + +--% 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] + +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] + +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 + +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] + +-- function for turning strings in tex format + +str2Outform s == + parse := ncParseFromString s or systemError '"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 + +str2Tex s == + outf := str2Outform s + val := coerceInt(mkObj(wrap outf, '(OutputForm)), '(TexFormat)) + val := objValUnwrap val + CAR val.1 + +opOf x == + atom x => x + first 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 +-- (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) + +searchCurrentEnv(x,currentEnv) == + for contour in currentEnv repeat + if u:= ASSQ(x,contour) then return (signal:= u) + 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 + +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] + +augProplistOf(var,prop,val,e) == + 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 + +addBinding(var,proplist,e is [[curContour,:tailContour],:tailEnv]) == + EQ(proplist,getProplist(var,e)) => e + $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] + +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) + +insert(x,y) == + member(x,y) => y + [x,:y] + +after(u,v) == + r:= u + for x in u for y in v repeat r:= rest r + r + + +$blank := char ('_ ) + +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 + +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 + +pp x == + PRETTYPRINT x + x + +pr x == + F_,PRINT_-ONE x + nil + +quickAnd(a,b) == + a = true => b + b = true => a + a = false or b = false => false + simpBool ['AND,a,b] + +quickOr(a,b) == + a = true or b = true => true + b = false => a + a = false => b + simpCatPredicate simpBool ['OR,a,b] + +intern x == + STRINGP x => + DIGITP x.0 => string2Integer x + INTERN x + x + +--------------------> NEW DEFINITION (override in interop.boot.pamphlet) +isDomain a == + REFVECP a and #a>5 and GETDATABASE(a.0,'CONSTRUCTORKIND) = 'domain + +-- 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") + +isDefaultPackageName x == (s := PNAME x).(MAXINDEX s) = char '_& + + +-- gensym utils + +charDigitVal c == + digits := '"0123456789" + n := -1 + for i in 0..#digits-1 while n < 0 repeat + if c = digits.i then n := i + n < 0 => error '"Character is not a digit" + n + +gensymInt g == + not GENSYMP g => error '"Need a GENSYM" + p := PNAME g + n := 0 + for i in 2..#p-1 repeat n := 10 * n + charDigitVal p.i + n + + + +-- Push into the BOOT package when invoked in batch mode. +AxiomCore::$sysScope := '"BOOT" +@ + + +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} -- cgit v1.2.3