From 6c715d9b21d64a8d6e46563d238c5526cab811a3 Mon Sep 17 00:00:00 2001 From: dos-reis Date: Mon, 15 Oct 2007 07:32:38 +0000 Subject: remove more pamphlets from interp/ --- src/interp/as.boot | 1188 ++++++++++++++++++++++++++++++++++ src/interp/as.boot.pamphlet | 1226 ----------------------------------- src/interp/ax.boot | 385 +++++++++++ src/interp/ax.boot.pamphlet | 431 ------------- src/interp/bc-matrix.boot | 2 + src/interp/bc-misc.boot | 929 ++++++++++++++++++++++++++ src/interp/bc-misc.boot.pamphlet | 949 --------------------------- src/interp/bc-solve.boot | 368 +++++++++++ src/interp/bc-solve.boot.pamphlet | 388 ----------- src/interp/bc-util.boot | 130 ++++ src/interp/bc-util.boot.pamphlet | 150 ----- src/interp/buildom.boot | 366 +++++++++++ src/interp/buildom.boot.pamphlet | 386 ----------- src/interp/c-util.boot | 715 +++++++++++++++++++++ src/interp/c-util.boot.pamphlet | 740 --------------------- src/interp/clam.boot | 705 ++++++++++++++++++++ src/interp/clam.boot.pamphlet | 730 --------------------- src/interp/cparse.boot | 2 + src/interp/cstream.boot | 113 ++++ src/interp/cstream.boot.pamphlet | 147 ----- src/interp/format.boot | 787 +++++++++++++++++++++++ src/interp/format.boot.pamphlet | 807 ----------------------- src/interp/g-boot.boot | 463 +++++++++++++ src/interp/g-boot.boot.pamphlet | 487 -------------- src/interp/g-cndata.boot | 245 +++++++ src/interp/g-cndata.boot.pamphlet | 265 -------- src/interp/g-error.boot | 202 ++++++ src/interp/g-error.boot.pamphlet | 225 ------- src/interp/g-opt.boot | 401 ++++++++++++ src/interp/g-opt.boot.pamphlet | 421 ------------ src/interp/g-timer.boot | 276 ++++++++ src/interp/g-timer.boot.pamphlet | 296 --------- src/interp/g-util.boot | 638 ++++++++++++++++++ src/interp/g-util.boot.pamphlet | 664 ------------------- src/interp/hashcode.boot | 111 ++++ src/interp/hashcode.boot.pamphlet | 131 ---- src/interp/ht-root.boot | 295 +++++++++ src/interp/ht-root.boot.pamphlet | 315 --------- src/interp/ht-util.boot | 735 +++++++++++++++++++++ src/interp/ht-util.boot.pamphlet | 755 ---------------------- src/interp/htcheck.boot | 133 ++++ src/interp/htcheck.boot.pamphlet | 157 ----- src/interp/htsetvar.boot | 483 ++++++++++++++ src/interp/htsetvar.boot.pamphlet | 503 --------------- src/interp/hypertex.boot | 125 ++++ src/interp/hypertex.boot.pamphlet | 145 ----- src/interp/macex.boot | 191 ++++++ src/interp/macex.boot.pamphlet | 211 ------ src/interp/nag-c02.boot | 2 + src/interp/nag-c05.boot | 2 + src/interp/nag-c06.boot | 2 + src/interp/nag-d01.boot | 2 + src/interp/nag-d02.boot | 2 + src/interp/nag-d03.boot | 2 + src/interp/nag-e01.boot | 2 + src/interp/nag-e02.boot | 2 + src/interp/nag-e02b.boot | 2 + src/interp/nag-e04.boot | 2 + src/interp/nag-f01.boot | 2 + src/interp/nag-f02.boot | 2 + src/interp/nag-f04.boot | 2 + src/interp/nag-f07.boot | 2 + src/interp/nag-s.boot | 2 + src/interp/osyscmd.boot | 55 ++ src/interp/osyscmd.boot.pamphlet | 75 --- src/interp/package.boot | 276 ++++++++ src/interp/package.boot.pamphlet | 300 --------- src/interp/packtran.boot | 62 ++ src/interp/packtran.boot.pamphlet | 86 --- src/interp/pathname.boot | 146 +++++ src/interp/pathname.boot.pamphlet | 166 ----- src/interp/pf2sex.boot | 463 +++++++++++++ src/interp/pf2sex.boot.pamphlet | 526 --------------- src/interp/pile.boot | 2 + src/interp/profile.boot | 94 +++ src/interp/profile.boot.pamphlet | 114 ---- src/interp/pspad1.boot | 743 +++++++++++++++++++++ src/interp/pspad1.boot.pamphlet | 767 ---------------------- src/interp/pspad2.boot | 663 +++++++++++++++++++ src/interp/pspad2.boot.pamphlet | 683 -------------------- src/interp/ptrees.boot | 772 ++++++++++++++++++++++ src/interp/ptrees.boot.pamphlet | 793 ----------------------- src/interp/redefs.boot.pamphlet | 92 --- src/interp/rulesets.boot | 308 +++++++++ src/interp/rulesets.boot.pamphlet | 328 ---------- src/interp/server.boot | 223 +++++++ src/interp/server.boot.pamphlet | 243 ------- src/interp/showimp.boot | 2 + src/interp/simpbool.boot | 205 ++++++ src/interp/simpbool.boot.pamphlet | 225 ------- src/interp/slam.boot | 338 ++++++++++ src/interp/slam.boot.pamphlet | 360 ----------- src/interp/sys-constants.boot | 4 +- src/interp/sys-driver.boot | 2 + src/interp/sys-globals.boot | 2 + src/interp/template.boot | 2 + src/interp/termrw.boot | 2 + src/interp/topics.boot | 2 + src/interp/trace.boot | 2 + src/interp/varini.boot | 2 + src/interp/wi1.boot | 1263 ++++++++++++++++++++++++++++++++++++ src/interp/wi1.boot.pamphlet | 1287 ------------------------------------- src/interp/wi2.boot | 1231 +++++++++++++++++++++++++++++++++++ src/interp/wi2.boot.pamphlet | 1255 ------------------------------------ src/interp/xrun.boot | 2 + src/interp/xruncomp.boot | 2 + 106 files changed, 16884 insertions(+), 17831 deletions(-) create mode 100644 src/interp/as.boot delete mode 100644 src/interp/as.boot.pamphlet create mode 100644 src/interp/ax.boot delete mode 100644 src/interp/ax.boot.pamphlet create mode 100644 src/interp/bc-misc.boot delete mode 100644 src/interp/bc-misc.boot.pamphlet create mode 100644 src/interp/bc-solve.boot delete mode 100644 src/interp/bc-solve.boot.pamphlet create mode 100644 src/interp/bc-util.boot delete mode 100644 src/interp/bc-util.boot.pamphlet create mode 100644 src/interp/buildom.boot delete mode 100644 src/interp/buildom.boot.pamphlet create mode 100644 src/interp/c-util.boot delete mode 100644 src/interp/c-util.boot.pamphlet create mode 100644 src/interp/clam.boot delete mode 100644 src/interp/clam.boot.pamphlet create mode 100644 src/interp/cstream.boot delete mode 100644 src/interp/cstream.boot.pamphlet create mode 100644 src/interp/format.boot delete mode 100644 src/interp/format.boot.pamphlet create mode 100644 src/interp/g-boot.boot delete mode 100644 src/interp/g-boot.boot.pamphlet create mode 100644 src/interp/g-cndata.boot delete mode 100644 src/interp/g-cndata.boot.pamphlet create mode 100644 src/interp/g-error.boot delete mode 100644 src/interp/g-error.boot.pamphlet create mode 100644 src/interp/g-opt.boot delete mode 100644 src/interp/g-opt.boot.pamphlet create mode 100644 src/interp/g-timer.boot delete mode 100644 src/interp/g-timer.boot.pamphlet create mode 100644 src/interp/g-util.boot delete mode 100644 src/interp/g-util.boot.pamphlet create mode 100644 src/interp/hashcode.boot delete mode 100644 src/interp/hashcode.boot.pamphlet create mode 100644 src/interp/ht-root.boot delete mode 100644 src/interp/ht-root.boot.pamphlet create mode 100644 src/interp/ht-util.boot delete mode 100644 src/interp/ht-util.boot.pamphlet create mode 100644 src/interp/htcheck.boot delete mode 100644 src/interp/htcheck.boot.pamphlet create mode 100644 src/interp/htsetvar.boot delete mode 100644 src/interp/htsetvar.boot.pamphlet create mode 100644 src/interp/hypertex.boot delete mode 100644 src/interp/hypertex.boot.pamphlet create mode 100644 src/interp/macex.boot delete mode 100644 src/interp/macex.boot.pamphlet create mode 100644 src/interp/osyscmd.boot delete mode 100644 src/interp/osyscmd.boot.pamphlet create mode 100644 src/interp/package.boot delete mode 100644 src/interp/package.boot.pamphlet create mode 100644 src/interp/packtran.boot delete mode 100644 src/interp/packtran.boot.pamphlet create mode 100644 src/interp/pathname.boot delete mode 100644 src/interp/pathname.boot.pamphlet create mode 100644 src/interp/pf2sex.boot delete mode 100644 src/interp/pf2sex.boot.pamphlet create mode 100644 src/interp/profile.boot delete mode 100644 src/interp/profile.boot.pamphlet create mode 100644 src/interp/pspad1.boot delete mode 100644 src/interp/pspad1.boot.pamphlet create mode 100644 src/interp/pspad2.boot delete mode 100644 src/interp/pspad2.boot.pamphlet create mode 100644 src/interp/ptrees.boot delete mode 100644 src/interp/ptrees.boot.pamphlet delete mode 100644 src/interp/redefs.boot.pamphlet create mode 100644 src/interp/rulesets.boot delete mode 100644 src/interp/rulesets.boot.pamphlet create mode 100644 src/interp/server.boot delete mode 100644 src/interp/server.boot.pamphlet create mode 100644 src/interp/simpbool.boot delete mode 100644 src/interp/simpbool.boot.pamphlet create mode 100644 src/interp/slam.boot delete mode 100644 src/interp/slam.boot.pamphlet create mode 100644 src/interp/wi1.boot delete mode 100644 src/interp/wi1.boot.pamphlet create mode 100644 src/interp/wi2.boot delete mode 100644 src/interp/wi2.boot.pamphlet (limited to 'src') diff --git a/src/interp/as.boot b/src/interp/as.boot new file mode 100644 index 00000000..189b5f7d --- /dev/null +++ b/src/interp/as.boot @@ -0,0 +1,1188 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- 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. + + +import '"macros" +)package "BOOT" + +--global hash tables for new compiler +$docHash := MAKE_-HASH_-TABLE() +$conHash := MAKE_-HASH_-TABLE() +$opHash := MAKE_-HASH_-TABLE() +$asyPrint := false + +asList() == + OBEY '"rm -f temp.text" + OBEY '"ls as/*.asy > temp.text" + instream := OPEN '"temp.text" + lines := [READLINE instream while not EOFP instream] + CLOSE instream + lines + +asAll lines == + for x in lines repeat + sayBrightly ['"-----> ",x] + asTran x + 'done + +as name == + astran STRCONC(STRINGIMAGE name,'".asy") + 'done + +astran asyFile == +--global hash tables for new compiler + $docHash := MAKE_-HASH_-TABLE() + $conHash := MAKE_-HASH_-TABLE() + $constantHash := MAKE_-HASH_-TABLE() + $niladics : local := nil + $asyFile: local := asyFile + $asFilename: local := STRCONC(PATHNAME_-NAME asyFile,'".as") + asytran asyFile + conlist := [x for x in HKEYS $conHash | HGET($conHash,x) isnt [.,.,"function",:.]] + $mmAlist : local := + [[con,:asyConstructorModemap con] for con in conlist] + $docAlist : local := + [[con,:REMDUP asyDocumentation con] for con in conlist] + $parentsHash : local := MAKE_-HASH_-TABLE() +--$childrenHash: local := MAKE_-HASH_-TABLE() + for con in conlist repeat + parents := asyParents con + HPUT($parentsHash,con,asyParents con) +-- for [parent,:pred] in parents repeat +-- parentOp := opOf parent +-- HPUT($childrenHash,parentOp,insert([con,:pred],HGET($childrenHash,parentOp))) + $newConlist := union(conlist, $newConlist) + [[x,:asMakeAlist x] for x in HKEYS $conHash] + +asyParents(conform) == + acc := nil + con:= opOf conform +--formals := TAKE(#formalParams,$TriangleVariableList) + modemap := LASSOC(con,$mmAlist) + $constructorCategory :local := asySubstMapping CADAR modemap + for x in folks $constructorCategory repeat +-- x := SUBLISLIS(formalParams,formals,x) +-- x := SUBLISLIS(IFCDR conform,formalParams,x) +-- x := SUBST('Type,'Object,x) + acc := [:explodeIfs x,:acc] + NREVERSE acc + +asySubstMapping u == + u is [op,:r] => + op = "->" => + [s, t] := r + args := + s is [op,:u] and asyComma? op => [asySubstMapping y for y in u] + [asySubstMapping s] + ['Mapping, asySubstMapping t, :args] + [asySubstMapping x for x in u] + u + +--asyFilePackage asyFile == +-- name := INTERN PATHNAME_-NAME asyFile +-- modemap := +-- [[[name],['CATEGORY,'domain, +-- :[asyMkSignature(con,CDAR mm) for [con,:mm] in $mmAlist]]],['T,name]] +-- opAlist := [[con,[CDAR mm]] for [con,:mm] in $mmAlist] +-- documentation := +-- [[con,[CDAR mm,fn LASSOC(con,$docAlist)]] for [con,:mm] in $mmAlist] +-- where fn u == +-- LASSOC('constructor,u) is [[=nil,doc]] => doc +-- '"" +-- res := [['constructorForm,name],['constant,:'true], +-- ['constructorKind,:'file], +-- ['constructorModemap,:modemap], +-- ['sourceFile,:PNAME name], +-- ['operationAlist,:zeroOneConversion opAlist], +-- ['documentation,:documentation]] +--asyDisplay(name,res) +-- [name,:res] + +asyMkSignature(con,sig) == +-- atom sig => ['TYPE,con,sig] +-- following line converts constants into nullary functions + atom sig => ['SIGNATURE,con,[sig]] + ['SIGNATURE,con,sig] + +asMakeAlist con == + record := HGET($conHash,con) + [form,sig,predlist,kind,exposure,comments,typeCode,:filename] := first record +--TTT in case we put the wrong thing in for niladic catgrs +--if ATOM(form) and kind='category then form:=[form] + if ATOM(form) then form:=[form] + kind = 'function => asMakeAlistForFunction con + abb := asyAbbreviation(con,#(KDR sig)) + if null KDR form then PUT(opOf form,'NILADIC,'T) + modemap := asySubstMapping LASSOC(con,$mmAlist) + $constructorCategory :local := CADAR modemap + parents := mySort HGET($parentsHash,con) +--children:= mySort HGET($childrenHash,con) + alists := HGET($opHash,con) + opAlist := SUBLISLIS($FormalMapVariableList,KDR form,CDDR alists) + ancestorAlist:= SUBLISLIS($FormalMapVariableList,KDR form,CAR alists) + catAttrs := [[x,:true] for x in getAttributesFromCATEGORY $constructorCategory] + attributeAlist := REMDUP [:CADR alists,:catAttrs] + documentation := + SUBLISLIS($FormalMapVariableList,KDR form,LASSOC(con,$docAlist)) + filestring := STRCONC(PATHNAME_-NAME STRINGIMAGE filename,'".as") + constantPart := HGET($constantHash,con) and [['constant,:true]] + niladicPart := MEMQ(con,$niladics) and [['NILADIC,:true]] + falist := TAKE(#KDR form,$FormalMapVariableList) + constructorCategory := + kind = 'category => + talist := TAKE(#KDR form, $TriangleVariableList) + SUBLISLIS(talist, falist, $constructorCategory) + SUBLISLIS(falist,KDR form,$constructorCategory) + if constructorCategory='Category then kind := 'category + exportAlist := asGetExports(kind, form, constructorCategory) + constructorModemap := SUBLISLIS(falist,KDR form,modemap) +--TTT fix a niladic category constructormodemap (remove the joins) + if kind = 'category then + SETF(CADAR(constructorModemap),['Category]) + res := [['constructorForm,:form],:constantPart,:niladicPart, + ['constructorKind,:kind], + ['constructorModemap,:constructorModemap], + ['abbreviation,:abb], + ['constructorCategory,:constructorCategory], + ['parents,:parents], + ['attributes,:attributeAlist], + ['ancestors,:ancestorAlist], + -- ['children,:children], + ['sourceFile,:filestring], + ['operationAlist,:zeroOneConversion opAlist], + ['modemaps,:asGetModemaps(exportAlist,form,kind,modemap)], + ['sourcefile,:$asFilename], + ['typeCode,:typeCode], + ['documentation,:documentation]] + if $asyPrint then asyDisplay(con,res) + res + +asGetExports(kind, conform, catform) == + u := asCategoryParts(kind, conform, catform, true) or return nil + -- ensure that signatures are lists + [[op, sigpred] for [op,sig,:pred] in CDDR u] where + sigpred() == + pred := + pred = "T" => nil + pred + [sig, nil, :pred] + +asMakeAlistForFunction fn == + record := HGET($conHash,fn) + [form,sig,predlist,kind,exposure,comments,typeCode,:filename] := first record + modemap := LASSOC(fn,$mmAlist) + newsig := asySignature(sig,nil) + opAlist := [[fn,[newsig,nil,:predlist]]] + res := [['modemaps,:asGetModemaps(opAlist,fn,'function,modemap)], + ['typeCode,:typeCode]] + if $asyPrint then asyDisplay(fn,res) + res + +getAttributesFromCATEGORY catform == + catform is ['CATEGORY,.,:r] => [y for x in r | x is ['ATTRIBUTE,y]] + catform is ['Join,:m,x] => getAttributesFromCATEGORY x + nil + +displayDatabase x == main where + main() == + for y in + '(CONSTRUCTORFORM CONSTRUCTORKIND _ + CONSTRUCTORMODEMAP _ + ABBREVIATION _ + CONSTRUCTORCATEGORY _ + PARENTS _ + ATTRIBUTES _ + ANCESTORS _ + SOURCEFILE _ + OPERATIONALIST _ + MODEMAPS _ + SOURCEFILE _ + DOCUMENTATION) repeat fn(x,y) + where + fn(x,y) == + sayBrightly ['"----------------- ",y,'" --------------------"] + pp GETDATABASE(x,y) + +-- For some reason Dick has modified as.boot to convert the +-- identifier |0| or |1| to an integer in the list of operations. +-- This is WRONG, all existing code assumes that operation names +-- are always identifiers not numbers. +-- This function breaks the ability of the interpreter to find +-- |0| or |1| as exports of new compiler domains. +-- Unless someone has a strong reason for keeping the change, +-- this function should be no-opped, i.e. +-- zeroOneConversion opAlist == opAlist +-- If this change is made, then we are able to find asharp constants again. +-- bmt Mar 26, 1994 and executed by rss + +zeroOneConversion opAlist == opAlist +-- for u in opAlist repeat +-- [op,:.] := u +-- DIGITP (PNAME op).0 => RPLACA(u, string2Integer PNAME op) +-- opAlist + +asyDisplay(con,alist) == + banner := '"==============================" + sayBrightly [banner,'" ",con,'" ",banner] + for [prop,:value] in alist repeat + sayBrightlyNT [prop,'": "] + pp value + +asGetModemaps(opAlist,oform,kind,modemap) == + acc:= nil + rpvl:= + MEMQ(kind, '(category function)) => rest $PatternVariableList -- *1 is special for $ + $PatternVariableList + form := [opOf oform,:[y for x in KDR oform for y in rpvl]] + dc := + MEMQ(kind, '(category function)) => "*1" + form + pred1 := + kind = 'category => [["*1",form]] + nil + signature := CDAR modemap + domainList := + [[a,m] for a in rest form for m in rest signature | + asIsCategoryForm m] + catPredList:= + kind = 'function => [["isFreeFunction","*1",opOf form]] + [['ofCategory,:u] for u in [:pred1,:domainList]] +-- for [op,:itemlist] in SUBLISLIS(rpvl, $FormalMapVariableList,opAlist) repeat +-- the code seems to oscillate between generating $FormalMapVariableList +-- and generating $TriangleVariableList + for [op,:itemlist] in SUBLISLIS(rpvl, $FormalMapVariableList,opAlist) repeat + for [sig0, pred] in itemlist repeat + sig := SUBST(dc,"$",sig0) + pred:= SUBST(dc,"$",pred) + sig := SUBLISLIS(rpvl,KDR oform,sig) + pred:= SUBLISLIS(rpvl,KDR oform,pred) + pred := pred or 'T + ----------> Constants change <-------------- + if IDENTP sig0 then + sig := [sig] + pred := MKPF([pred,'(isAsConstant)],'AND) + pred' := MKPF([pred,:catPredList],'AND) + mm := [[dc,:sig],[pred']] + acc := [[op,:interactiveModemapForm mm],:acc] + NREVERSE acc + +asIsCategoryForm m == + m = 'BasicType or GETDATABASE(opOf m,'CONSTRUCTORKIND) = 'category + +asyDocumentation con == + docHash := HGET($docHash,con) + u := [[op,:[fn(x,op) for x in rec]] for op in HKEYS docHash + | rec := HGET(docHash,op)] where fn(x,op) == + [form,sig,pred,origin,where?,comments,:.] := x + ----------> Constants change <-------------- + if IDENTP sig then sig := [sig] + [asySignature(sig,nil),trimComments comments] + [form,sig,pred,origin,where?,comments] := first HGET($conHash,con) + --above "first" assumes only one entry + comments := trimComments asyExtractDescription comments + [:u,['constructor,[nil,comments]]] + +asyExtractDescription str == + k := STRPOS('"Description:",str,0,nil) => asyExtractDescription SUBSTRING(str,k + 12,nil) + k := STRPOS('"Author:",str,0,nil) => asyExtractDescription SUBSTRING(str,0,k) + str + +trimComments str == + null str or str = '"" => '"" + m := MAXINDEX str + str := SUBSTRING(str,0,m) + trimString str + +asyExportAlist con == +--format of 'operationAlist property of LISPLIBS (as returned from koOps): +-- +-- +--!!! asyFile NEED: need to know if function is implemented by domain!!! + docHash := HGET($docHash,con) + [[op,:[fn(x,op) for x in rec]] for op in HKEYS docHash | rec := HGET(docHash,op)] + where fn(x,op) == + [form,sig,pred,origin,where?,comments,:.] := x + tail := + pred => [pred] + nil + newSig := asySignature(sig,nil) + [newSig,nil,:tail] + +asyMakeOperationAlist(con,proplist, key) == + oplist := + u := LASSOC('domExports,proplist) => + kind := 'domain + u + u := LASSOC('catExports,proplist) => + kind := 'category + u + key = 'domain => + kind := 'domain + u := NIL + return nil + ht := MAKE_-HASH_-TABLE() + ancestorAlist := nil + for ['Declare,id,form,r] in oplist repeat + id = "%%" => + opOf form = con => nil + y := asyAncestors form + [attrs, na] := asyFindAttrs y + y := na + if opOf(y)^=con then ancestorAlist := [ [y,:true],:ancestorAlist] + idForm := + form is ['Apply,'_-_>,source,target] => [id,:asyArgs source] + ----------> Constants change <-------------- + id + pred := + LASSOC('condition,r) is p => hackToRemoveAnd p + nil + sig := asySignature(asytranForm(form,[idForm],nil),nil) + entry := + --id ^= "%%" and IDENTP idForm => [[sig],nil,nil,'ASCONST] + id ^= "%%" and IDENTP idForm => + pred => [[sig],nil,asyPredTran pred,'ASCONST] + [[sig],nil,true,'ASCONST] + pred => [sig,nil,asyPredTran pred] + [sig] + HPUT(ht,id,[entry,:HGET(ht,id)]) + opalist := [[op,:REMDUP HGET(ht,op)] for op in HKEYS ht] + --HPUT($opHash,con,[ancestorAlist,attributeAlist,:opalist]) + HPUT($opHash,con,[ancestorAlist,nil,:opalist]) + +hackToRemoveAnd p == +---remove this as soon as .asy files do not contain forms (And pred) forms + p is ['And,q,:r] => + r => ['AND,q,:r] + q + p + +asyAncestors x == + x is ['Apply,:r] => asyAncestorList r + x is [op,y,:.] and MEMQ(op, '(PretendTo RestrictTo)) => asyAncestors y + atom x => + x = '_% => '_$ + MEMQ(x, $niladics) => [x] + GETDATABASE(x ,'NILADIC) => [x] + x + asyAncestorList x + +asyAncestorList x == [asyAncestors y for y in x] +--============================================================================ +-- Build Operation Alist from sig +--============================================================================ + +--format of operations as returned from koOps +-- +-- + +--abb,kind,file,sourcefile,coSig,dbLineNumber,constructorArgs,libfile +--((sig where(NIL or #) condition(T or pred) ELTorSubsumed) ... +--expanded lists are: sig, predicate, origin, exposeFlag, comments + +--============================================================================ +-- Building Hash Tables for Operations/Constructors +--============================================================================ +asytran fn == +--put operations into table format for browser: +-- + inStream := OPEN fn + sayBrightly ['" Reading ",fn] + u := VMREAD inStream + $niladics := mkNiladics u + for x in $niladics repeat PUT(x,'NILADIC,true) + for d in u repeat + ['Declare,name,:.] := d + name = "%%" => 'skip --skip over top-level properties + $docHashLocal: local := MAKE_-HASH_-TABLE() + asytranDeclaration(d,'(top),nil,false) + if null name then hohohoho() + HPUT($docHash,name,$docHashLocal) + CLOSE inStream + 'done + +mkNiladics u == + [name for x in u | x is ['Declare,name,y,:.] and y isnt ['Apply,'_-_>,:.]] + +--OLD DEFINITION FOLLOWS +asytranDeclaration(dform,levels,predlist,local?) == + ['Declare,id,form,r] := dform + id = 'failed => id + KAR dform ^= 'Declare => systemError '"asytranDeclaration" + if levels = '(top) then + if form isnt ['Apply,"->",:.] then HPUT($constantHash,id,true) + comments := LASSOC('documentation,r) or '"" + idForm := + levels is ['top,:.] => + form is ['Apply,'_-_>,source,target] => [id,:asyArgs source] + id + ----------> Constants change <-------------- + id + newsig := asytranForm(form,[idForm,:levels],local?) + key := + levels is ['top,:.] => + MEMQ(id,'(%% Category Type)) => 'constant + asyLooksLikeCatForm? form => 'category + form is ['Apply, '_-_>,.,u] => + if u is ['Apply, construc,:.] then u:= construc + GETDATABASE(opOf u,'CONSTRUCTORKIND) = 'domain => 'function + asyLooksLikeCatForm? u => 'category + 'domain + 'domain + first levels + typeCode := LASSOC('symeTypeCode,r) + record := [idForm,newsig,asyMkpred predlist,key,true,comments,typeCode,:$asyFile] + if not local? then + ht := + levels = '(top) => $conHash + $docHashLocal + HPUT(ht,id,[record,:HGET(ht,id)]) + if levels = '(top) then asyMakeOperationAlist(id,r, key) + ['Declare,id,newsig,r] + +asyLooksLikeCatForm? x == +--TTT don't see a Third in my version .... + x is ['Define, ['Declare, ., ['Apply, 'Third,:.],:.],:.] or + x is ['Define, ['Declare, ., 'Category ],:.] + +--asytranDeclaration(dform,levels,predlist,local?) == +-- ['Declare,id,form,r] := dform +-- id = 'failed => id +-- levels isnt ['top,:.] => asytranForm(form,[id,:levels],local?) +-- idForm := +-- form is ['Apply,'_-_>,source,target] => [id,:asyArgs source] +-- id +-- if form isnt ['Apply,"->",:.] then HPUT($constantHash,id,true) +-- comments := LASSOC('documentation,r) or '"" +-- newsig := asytranForm(form,[idForm,:levels],local?) +-- key := +-- MEMQ(id,'(%% Category Type)) => 'constant +-- form is ['Apply,'Third,:.] => 'category +-- form is ['Apply,.,.,target] and target is ['Apply,name,:.] +-- and MEMQ(name,'(Third Join)) => 'category +-- 'domain +-- record := [newsig,asyMkpred predlist,key,true,comments,:$asyFile] +-- if not local? then +-- ht := +-- levels = '(top) => $conHash +-- $docHashLocal +-- HPUT(ht,id,[record,:HGET(ht,id)]) +-- if levels = '(top) then asyMakeOperationAlist(id,r) +-- ['Declare,id,newsig,r] + +asyIsCatForm form == + form is ['Apply,:r] => + r is ['_-_>,.,a] => asyIsCatForm a + r is ['Third,'Type,:.] => true + false + false + +asyArgs source == + args := + source is [op,:u] and asyComma? op => u + [source] + [asyArg x for x in args] + +asyArg x == + x is ['Declare,id,:.] => id + x + +asyMkpred predlist == + null predlist => nil + predlist is [p] => p + ['AND,:predlist] + +asytranForm(form,levels,local?) == + u := asytranForm1(form,levels,local?) + null u => hahah() + u + +asytranForm1(form,levels,local?) == + form is ['With,left,cat] => +-- left ^= nil => error '"WITH cannot take a left argument yet" + asytranCategory(form,levels,nil,local?) + form is ['Apply,:.] => asytranApply(form,levels,local?) + form is ['Declare,:.] => asytranDeclaration(form,levels,nil,local?) + form is ['Comma,:r] => ['Comma,:[asytranForm(x,levels,local?) for x in r]] +--form is ['_-_>,:s] => asytranMapping(s,levels,local?) + form is [op,a,b] and MEMQ(a,'(PretendTo RestrictTo)) => + asytranForm1(a,levels,local?) + form is ['LitInteger,s] => + READ_-FROM_-STRING(s) + form is ['Define,:.] => + form is ['Define,['Declare,.,x,:.],rest] => +--TTT i don't know about this one but looks ok + x = 'Category => asytranForm1(rest,levels, local?) + asytranForm1(x,levels,local?) + error '"DEFINE forms are not handled yet" + if form = '_% then $hasPerCent := true + IDENTP form => + form = "%" => "$" + GETL(form,'NILADIC) => [form] + form + [asytranForm(x,levels,local?) for x in form] + +asytranApply(['Apply,name,:arglist],levels,local?) == + MEMQ(name,'(Record Union)) => + [name,:[asytranApplySpecial(x, levels, local?) for x in arglist]] + null arglist => [name] + name is [ 'RestrictTo, :.] => + asytranApply(['Apply, CAR CDR name,:arglist], levels, local?) + name is [ 'Qualify, :.] => + asytranApply(['Apply, CAR CDR name,:arglist], levels, local?) + name is 'string => asytranLiteral CAR arglist + name is 'integer => asytranLiteral CAR arglist + name is 'float => asytranLiteral CAR arglist + name = 'Enumeration => + ["Enumeration",:[asytranEnumItem arg for arg in arglist]] + [:argl,lastArg] := arglist + [name,:[asytranFormSpecial(arg,levels,true) for arg in argl], + asytranFormSpecial(lastArg,levels,false)] + +asytranLiteral(lit) == + CAR CDR lit + +asytranEnumItem arg == + arg is ['Declare, name, :.] => name + error '"Bad Enumeration entry" + +asytranApplySpecial(x, levels, local?) == + x is ['Declare, name, typ, :.] => [":",name,asytranForm(typ, levels, local?)] + asytranForm(x, levels, local?) + +asytranFormSpecial(x, levels, local?) == --> this throws away variable name (revise later) + x is ['Declare, name, typ, :.] => asytranForm(typ, levels, local?) + asytranForm(x, levels, local?) + +asytranCategory(form,levels,predlist,local?) == + cat := + form is ['With,left,right] => + right is ['Blank,:.] => ['Sequence] + right + form + left := + form is ['With,left,right] => + left is ['Blank,:.] => nil + left + nil + $hasPerCent: local := nil + items := + cat is ['Sequence,:s] => s + [cat] + catTable := MAKE_-HASH_-TABLE() + catList := nil + for x in items | x repeat + if null x then systemError() + dform := asytranCategoryItem(x,levels,predlist,local?) + null dform => nil + dform is ['Declare,id,record,r] => + HPUT(catTable,id,[asyWrap(record,predlist),:HGET(catTable,id)]) + catList := [asyWrap(dform,predlist),:catList] + keys := listSort(function GLESSEQP,HKEYS catTable) + right1 := NREVERSE catList + right2 := [[key,:HGET(catTable,key)] for key in keys] + right := + right2 => [:right1,['Exports,:right2]] + right1 + res := + left => [left,:right] + right + res is [x] and x is ['IF,:.] => x + ['With,:res] + +asyWrap(record,predlist) == + predlist => ['IF,MKPF(predlist,'AND),record] + record + +asytranCategoryItem(x,levels,predlist,local?) == + x is ['If,predicate,item,:r] => + IFCAR r => error '"ELSE expressions not allowed yet in conditionals" + pred := + predicate is ['Test,r] => r + predicate + asytranCategory(item,levels,[pred,:predlist],local?) + MEMQ(KAR x,'(Default Foreign)) => nil + x is ['Declare,:.] => asytranDeclaration(x,levels,predlist,local?) + x + +--============================================================================ +-- Extending Constructor Datatable +--============================================================================ +--FORMAT of $constructorDataTable entry: +--abb kind libFile sourceFile coSig constructorArgs +--alist is ((kind . domain) (libFile . MATRIX) (sourceFile . "matrix") +-- (coSig NIL T) (dbLineNumber . 29187) (constructorArgs R) +-- (modemap . ( +-- (|Matrix| |#1|) +-- (Join (MatrixCategory #1 (Vector #1) (Vector #1)) +-- (CATEGORY domain +-- (SIGNATURE diagonalMatrix ($ (Vector #1))) +-- (IF (has #1 (Field)) +-- (SIGNATURE inverse ((Union $ "failed") $)) noBranch))) +-- (Ring)) +-- (T Matrix)) ) +extendConstructorDataTable() == +-- tb := $constructorDataTable + for x in listSort(function GLESSEQP,HKEYS $conHash) repeat +-- if LASSOC(x,tb) then tb := DELLASOS(x,tb) + record := HGET($conHash,x) + [form,sig,predlist,origin,exposure,comments,typeCode,:filename] := first record + abb := asyAbbreviation(x,#(rest sig)) + kind := 'domain + --Note: this "first" assumes that there is ONLY one sig per name + cosig := [nil,:asyCosig sig] + args := asyConstructorArgs sig + tb := + [[x,abb, + ['kind,:kind], + ['cosig,:cosig], + ['libfile,filename], + ['sourceFile,STRINGIMAGE filename], + ['constructorArgs,:args]],:tb] + listSort(function GLESSEQP,ASSOCLEFT tb) + +asyConstructorArgs sig == + sig is ['With,:.] => nil + sig is ['_-_>,source,target] => + source is [op,:argl] and asyComma? op => [asyConstructorArg x for x in argl] + [asyConstructorArg source] + +asyConstructorArg x == + x is ['Declare,name,t,:.] => name + x + +asyCosig sig == --can be a type or could be a signature + atom sig or sig is ['With,:.] => nil + sig is ['_-_>,source,target] => + source is [op,:argl] and asyComma? op => [asyCosigType x for x in argl] + [asyCosigType source] + error false + +asyCosigType u == + u is [name,t] => + t is [fn,:.] => + asyComma? fn => fn + fn = 'With => 'T + nil + t = 'Type => 'T + error '"Unknown atomic type" + error false + +asyAbbreviation(id,n) == chk(id,main) where --> n = number of arguments + main() == + a := createAbbreviation id => a + name := PNAME id +-- #name < 8 => INTERN UPCASE name + parts := asySplit(name,MAXINDEX name) + newname := "STRCONC"/[asyShorten x for x in parts] + #newname < 8 => INTERN newname + tryname := SUBSTRING(name,0,7) + not createAbbreviation tryname => INTERN UPCASE tryname + nil + chk(conname,abb) == + (xx := asyGetAbbrevFromComments conname) => xx + con := abbreviation? abb => + conname = con => abb + conname + abb + +asyGetAbbrevFromComments con == + docHash := HGET($docHash,con) + u := [[op,:[fn(x,op) for x in rec]] for op in HKEYS docHash + | rec := HGET(docHash,op)] where fn(x,op) == + [form,sig,pred,origin,where?,comments,:.] := x + ----------> Constants change <-------------- + if IDENTP sig then sig := [sig] + [asySignature(sig,nil),trimComments comments] + [form,sig,pred,origin,where?,comments] := first HGET($conHash,con) + --above "first" assumes only one entry + x := asyExtractAbbreviation comments + x => intern x + NIL + +asyExtractAbbreviation str == + not (k:= STRPOS('"Abbrev: ",str,0,nil)) => NIL + str := SUBSTRING(str, k+8, nil) + k := STRPOS($stringNewline, str,0,nil) + k => SUBSTRING(str, 0, k) + str + +asyShorten x == + y := createAbbreviation x + or LASSOC(x, + '(("Small" . "SM") ("Single" ."S") ("Half" . "H")("Point" . "PT") + ("Floating" . "F") ("System" . "SYS") ("Number" . "N") + ("Inventor" . "IV") + ("Finite" . "F") ("Double" . "D") ("Builtin" . "BI"))) => y + UPCASE x + +asySplit(name,end) == + end < 1 => [name] + k := 0 + for i in 1..end while LOWER_-CASE_-P name.i repeat k := i + k := k + 1 + [SUBSTRING(name,0,k),:asySplit(SUBSTRING(name,k,nil),end-k)] + +createAbbreviation s == + if STRINGP s then s := INTERN s + a := constructor? s + a ^= s => a + nil + +--============================================================================ +-- extending getConstructorModemap Property +--============================================================================ +--Note: modemap property is built when getConstructorModemap is called + +asyConstructorModemap con == + HGET($conHash,con) isnt [record,:.] => nil --not there + [form,sig,predlist,kind,exposure,comments,typeCode,:filename] := record + $kind: local := kind + --NOTE: sig has the form (-> source target) or simply (target) + $constructorArgs: local := KDR form + signature := asySignature(sig,false) + formals := ['_$,:TAKE(#$constructorArgs,$FormalMapVariableList)] + mm := [[[con,:$constructorArgs],:signature],['T,con]] + SUBLISLIS(formals,['_%,:$constructorArgs],mm) + +asySignature(sig,names?) == + sig is ['Join,:.] => [asySig(sig,nil)] + sig is ['With,:.] => [asySig(sig,nil)] + sig is ['_-_>,source,target] => + target := + names? => ['dummy,target] + target + source is [op,:argl] and asyComma? op => + [asySigTarget(target,names?),:[asySig(x,names?) for x in argl]] + [asySigTarget(target,names?),asySig(source,names?)] + ----------> The following is a hack for constants which are category names<-- + sig is ['Third,:.] => [asySig(sig,nil)] + ----------> Constants change <-------------- + asySig(sig,nil) + +asySigTarget(u,name?) == asySig1(u,name?,true) + +asySig(u,name?) == asySig1(u,name?,false) + +asySig1(u,name?,target?) == + x := + name? and u is [name,t] => t + u + x is [fn,:r] => + fn = 'Join => asyTypeJoin r ---------> jump out to newer code 4/94 + MEMQ(fn, '(RestrictTo PretendTo)) => asySig(first r,name?) + asyComma? fn => + u := [asySig(x,name?) for x in r] + target? => + null u => '(Void) + -- this implies a multiple value return, not currently supported + -- in the interpreter + ['Multi,:u] + u + fn = 'With => asyCATEGORY r + fn = 'Third => + r is [b] => + b is ['With,:s] => asyCATEGORY s + b is ['Blank,:.] => asyCATEGORY nil + error x + fn = 'Apply and r is ['_-_>,:s] => asyMapping(s,name?) + fn = '_-_> => asyMapping(r,name?) + fn = 'Declare and r is [name,typ,:.] => + asySig1(typ, name?, target?) + x is '(_%) => '(_$) + [fn,:[asySig(x,name?) for x in r]] +--x = 'Type => '(Type) + x = '_% => '_$ + x + +-- old version was : +--asyMapping([a,b],name?) == +-- a := asySig(a,name?) +-- b := asySig(b,name?) +-- args := +-- a is [op,:r] and asyComma? op => r +-- [a] +-- ['Mapping,b,:args] + +asyMapping([a,b],name?) == + newa := asySig(a,name?) + b := asySig(b,name?) + args := + a is [op,:r] and asyComma? op => newa + [a] + ['Mapping,b,:args] + +--============================================================================ +-- code for asySignatures of the form (Join,:...) +--============================================================================ +asyType x == + x is [fn,:r] => + fn = 'Join => asyTypeJoin r + MEMQ(fn, '(RestrictTo PretendTo)) => asyType first r + asyComma? fn => + u := [asyType x for x in r] + u + fn = 'With => asyCATEGORY r + fn = '_-_> => asyTypeMapping r + fn = 'Apply => r +-- fn = 'Declare and r is [name,typ,:.] => typ + x is '(_%) => '(_$) + x +--x = 'Type => '(Type) + x = '_% => '_$ + x + +asyTypeJoin r == + $conStack : local := nil + $opStack : local := nil + $predlist : local := nil + for x in r repeat asyTypeJoinPart(x,$predlist) + catpart := + $opStack => ['CATEGORY,$kind,:asyTypeJoinStack REVERSE $opStack] + nil + conpart := asyTypeJoinStack REVERSE $conStack + conpart => + catpart => ['Join,:conpart,catpart] + CDR conpart => ['Join,:conpart] + conpart + catpart + +asyTypeJoinPart(x,$predlist) == + x is ['Join,:y] => for z in y repeat asyTypeJoinPart(z, $predlist) + x is ['With,:y] => for p in y repeat asyTypeJoinPartWith p + asyTypeJoinPartWith x + +asyTypeJoinPartWith x == + x is ['Exports,:y] => for p in y repeat asyTypeJoinPartExport p + x is ['Exports,:.] => systemError 'exports + x is ['Comma] => nil + x is ['Export,:y] => nil + x is ['IF,:r] => asyTypeJoinPartIf r + x is ['Sequence,:x] => for y in x repeat asyTypeJoinItem y + asyTypeJoinItem x + +asyTypeJoinPartIf [pred,value] == + predlist := [asyTypeJoinPartPred pred,:$predlist] + asyTypeJoinPart(value,predlist) + +asyTypeJoinPartPred x == + x is ['Test, y] => asyTypeUnit y + asyTypeUnit x + +asyTypeJoinItem x == + result := asyTypeUnit x + isLowerCaseLetter (PNAME opOf result).0 => + $opStack := [[['ATTRIBUTE,result],:$predlist],:$opStack] + $conStack := [[result,:$predlist],:$conStack] + +asyTypeMapping([a,b]) == + a := asyTypeUnit a + b := asyTypeUnit b + args := + a is [op,:r] and asyComma? op => r + [a] + ['Mapping,b,:args] + +asyTypeUnit x == + x is [fn,:r] => + fn = 'Join => systemError 'Join ----->asyTypeJoin r + MEMQ(fn, '(RestrictTo PretendTo)) => asyTypeUnit first r + asyComma? fn => + u := [asyTypeUnit x for x in r] + u + fn = 'With => asyCATEGORY r + fn = '_-_> => asyTypeMapping r + fn = 'Apply => asyTypeUnitList r + fn = 'Declare and r is [name,typ,:.] => asyTypeUnitDeclare(name,typ) + x is '(_%) => '(_$) + [fn,:asyTypeUnitList r] + GETL(x,'NILADIC) => [x] +--x = 'Type => '(Type) + x = '_% => '_$ + x + +asyTypeUnitList x == [asyTypeUnit y for y in x] + +asyTypeUnitDeclare(op,typ) == + typ is ['Apply, :r] => asyCatSignature(op,r) + asyTypeUnit typ +--============================================================================ +-- Translator for ['With,:.] +--============================================================================ +asyCATEGORY x == + if x is [join,:y] and join is ['Apply,:s] then + exports := y + joins := + s is ['Join,:r] => [asyJoinPart u for u in r] + [asyJoinPart s] + else if x is [id,:y] and IDENTP id then + joins := [[id]] + exports := y + else + joins := nil + exports := x + cats := exports + operations := nil + if exports is [:r,['Exports,:ops]] then + cats := r + operations := ops + exportPart := + ['CATEGORY,'domain,:"APPEND"/[asyCatItem y for y in operations]] + [attribs, na] := asyFindAttrs joins + joins := na + cats := "append"/[asyCattran c for c in cats] + [a, na] := asyFindAttrs cats + cats := na + attribs := APPEND(attribs, a) + attribs := [['ATTRIBUTE, x] for x in attribs] + exportPart := [:exportPart,:attribs] + joins or cats or attribs => + ['Join,:joins,:cats, exportPart] + exportPart + +asyFindAttrs l == + attrs := [] + notattrs := [] + for x in l repeat + x0 := x + while CONSP x repeat x := CAR x + if MEMQ(x, _*ATTRIBUTES_*) then attrs := [:attrs, x] + else notattrs := [:notattrs, x0] + [attrs, notattrs] + +simpCattran x == + u := asyCattran x + u is [y] => y + ['Join,:u] + +asyCattran x == + x is ['With,:r] => "append"/[asyCattran1 x for x in r] + x is ['IF,:.] => "append"/[asyCattranConstructors(x,nil)] + [x] + +asyCattran1 x == + x is ['Exports,:y] => "append"/[asyCattranOp u for u in y] + x is ['IF,:.] => "append"/[asyCattranConstructors(x,nil)] + systemError nil + +asyCattranOp [op,:items] == + "append"/[asyCattranOp1(op,item,nil) for item in items] + +asyCattranOp1(op, item, predlist) == + item is ['IF, p, x] => + pred := asyPredTran + p is ['Test,t] => t + p +-- x is ['IF,:.] => "append"/[asyCattranOp1('IF, x, [pred,:predlist])] +-- This line used to call asyCattranOp1 with too few arguments. Following +-- fix suggested by RDJ. + x is ['IF,:.] => "append"/[asyCattranOp1(op,y,[pred,:predlist]) for y in x] + [['IF, asySimpPred(pred,predlist), asyCattranSig(op,x), 'noBranch]] + [asyCattranSig(op,item)] + +asyPredTran p == asyPredTran1 asyJoinPart p + +asyPredTran1 p == + p is ['Has,x,y] => ['has,x, simpCattran y] + p is ['Test, q] => asyPredTran1 q + p is [op,:r] and MEMQ(op,'(AND OR NOT)) => + [op,:[asyPredTran1 q for q in r]] + p + +asyCattranConstructors(item, predlist) == + item is ['IF, p, x] => + pred := asyPredTran + p is ['Test,t] => t + p + x is ['IF,:.] => "append"/[asyCattranConstructors(x, [pred,:predlist])] + form := ['ATTRIBUTE, asyJoinPart x] + [['IF, asySimpPred(pred,predlist), form, 'noBranch]] + systemError() + +asySimpPred(p, predlist) == + while predlist is [q,:predlist] repeat p := quickAnd(q,p) + p + +asyCattranSig(op,y) == + y isnt ["->",source,t] => +-- ['SIGNATURE, op, asyTypeUnit y] +-- following makes constants into nullary functions + ['SIGNATURE, op, [asyTypeUnit y]] + s := + source is ['Comma,:s] => [asyTypeUnit z for z in s] + [asyTypeUnit source] + t := asyTypeUnit t + null t => ['SIGNATURE,op,s] + ['SIGNATURE,op,[t,:s]] + +asyJoinPart x == + IDENTP x => [x] + asytranForm(x,nil,true) + +asyCatItem item == + atom item => [item] + item is ['IF,.,.] => [item] + [op,:sigs] := item + [asyCatSignature(op,sig) for sig in sigs | sig] + +asyCatSignature(op,sig) == + sig is ['_-_>,source,target] => + ['SIGNATURE,op, [asyTypeItem target,:asyUnTuple source]] + ----------> Constants change <-------------- +-- ['TYPE,op,asyTypeItem sig] +-- following line converts constants into nullary functions + ['SIGNATURE,op,[asyTypeItem sig]] + +asyUnTuple x == + x is [op,:u] and asyComma? op => [asyTypeItem y for y in u] + [asyTypeItem x] + +asyTypeItem x == + atom x => + x = '_% => '_$ + x + x is ['_-_>,a,b] => + ['Mapping,b,:asyUnTuple a] + x is ['Apply,:r] => + r is ['_-_>,a,b] => + ['Mapping,b,:asyUnTuple a] + r is ['Record,:parts] => + ['Record,:[[":",a,b] for ['Declare,a,b,:.] in parts]] + r is ['Segment,:parts] => + ['Segment,:[asyTypeItem x for x in parts]] + asytranApply(x,nil,true) + x is ['Declare,.,t,:.] => asyTypeItem t + x is ['Comma,:args] => + -- this implies a multiple value return, not currently supported + -- in the interpreter + args => ['Multi,:[asyTypeItem y for y in args]] + ['Void] + [asyTypeItem y for y in x] + +--============================================================================ +-- Utilities +--============================================================================ +asyComma? op == MEMQ(op,'(Comma Multi)) + + +hput(table,name,value) == + if null name then systemError() + HPUT(table,name,value) + +--============================================================================ +-- category parts +--============================================================================ + +-- this constructs operation information from a category. +-- NB: This is categoryParts, but with the kind supplied by +-- an arguments +asCategoryParts(kind,conform,category,:options) == main where + main() == + cons? := IFCAR options --means to include constructors as well + $attrlist: local := nil + $oplist : local := nil + $conslist: local := nil + conname := opOf conform + for x in exportsOf(category) repeat build(x,true) + $attrlist := listSort(function GLESSEQP,$attrlist) + $oplist := listSort(function GLESSEQP,$oplist) + res := [$attrlist,:$oplist] + if cons? then res := [listSort(function GLESSEQP,$conslist),:res] + if kind = 'category then + tvl := TAKE(#rest conform,$TriangleVariableList) + res := SUBLISLIS($FormalMapVariableList,tvl,res) + res + where + build(item,pred) == + item is ['SIGNATURE,op,sig,:.] => $oplist := [[opOf op,sig,:pred],:$oplist] + --note: opOf is needed!!! Bug in compiler puts in (One) and (Zero) + item is ['ATTRIBUTE,attr] => + constructor? opOf attr => + $conslist := [[attr,:pred],:$conslist] + nil + opOf attr = 'nothing => 'skip + $attrlist := [[opOf attr,IFCDR attr,:pred],:$attrlist] + item is ['TYPE,op,type] => + $oplist := [[op,[type],:pred],:$oplist] + item is ['IF,pred1,s1,s2] => + build(s1,quickAnd(pred,pred1)) + s2 => build(s2,quickAnd(pred,['NOT,pred1])) + item is ['PROGN,:r] => for x in r repeat build(x,pred) + item in '(noBranch) => 'ok + null item => 'ok + systemError '"build error" + exportsOf(target) == + target is ['CATEGORY,.,:r] => r + target is ['Join,:r,f] => + for x in r repeat $conslist := [[x,:true],:$conslist] + exportsOf f + $conslist := [[target,:true],:$conslist] + nil + +--============================================================================ +-- Dead Code (for a very odd value of 'dead') +--============================================================================ +asyTypeJoinPartExport x == + [op,:items] := x + for y in items repeat + y isnt ["->",source,t] => +-- sig := ['TYPE, op, asyTypeUnit y] +-- converts constants to nullary functions (this code isn't dead) + sig := ['SIGNATURE, op, [asyTypeUnit y]] + $opStack := [[sig,:$predlist],:$opStack] + s := + source is ['Comma,:s] => [asyTypeUnit z for z in s] + [asyTypeUnit source] + t := asyTypeUnit t + sig := + null t => ['SIGNATURE,op,s] + ['SIGNATURE,op,[t,:s]] + $opStack := [[sig,:$predlist],:$opStack] + +--============================================================================ +-- Code to create opDead Code +--============================================================================ +asyTypeJoinStack r == + al := [[[x while r is [[x, :q],:s] and p = q and (r := s; true)],:p] + while r is [[.,:p],:.]] + result := "append"/[fn for [y,:p] in al] where fn() == + p => [['IF,asyTypeMakePred p,:y]] + y + result + +asyTypeMakePred [p,:u] == + while u is [q,:u] repeat p := quickAnd(q,p) + p + + + + diff --git a/src/interp/as.boot.pamphlet b/src/interp/as.boot.pamphlet deleted file mode 100644 index 1d4849e2..00000000 --- a/src/interp/as.boot.pamphlet +++ /dev/null @@ -1,1226 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/as.boot} Pamphlet} -\author{The Axiom Team} - -\begin{document} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject - -\section{New Aldor compiler changes} - -This mod is used to make the open source version of Axiom work -with the new aldor compiler. -Aldor does not want the [[attributeAlist]]. -This used to read: -\begin{verbatim} - HPUT($opHash,con,[ancestorAlist,attributeAlist,:opalist]) -\end{verbatim} -but was changed to: -<>= - HPUT($opHash,con,[ancestorAlist,nil,:opalist]) -@ - -\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. - -@ -<<*>>= -<> - -import '"macros" -)package "BOOT" - ---global hash tables for new compiler -$docHash := MAKE_-HASH_-TABLE() -$conHash := MAKE_-HASH_-TABLE() -$opHash := MAKE_-HASH_-TABLE() -$asyPrint := false - -asList() == - OBEY '"rm -f temp.text" - OBEY '"ls as/*.asy > temp.text" - instream := OPEN '"temp.text" - lines := [READLINE instream while not EOFP instream] - CLOSE instream - lines - -asAll lines == - for x in lines repeat - sayBrightly ['"-----> ",x] - asTran x - 'done - -as name == - astran STRCONC(STRINGIMAGE name,'".asy") - 'done - -astran asyFile == ---global hash tables for new compiler - $docHash := MAKE_-HASH_-TABLE() - $conHash := MAKE_-HASH_-TABLE() - $constantHash := MAKE_-HASH_-TABLE() - $niladics : local := nil - $asyFile: local := asyFile - $asFilename: local := STRCONC(PATHNAME_-NAME asyFile,'".as") - asytran asyFile - conlist := [x for x in HKEYS $conHash | HGET($conHash,x) isnt [.,.,"function",:.]] - $mmAlist : local := - [[con,:asyConstructorModemap con] for con in conlist] - $docAlist : local := - [[con,:REMDUP asyDocumentation con] for con in conlist] - $parentsHash : local := MAKE_-HASH_-TABLE() ---$childrenHash: local := MAKE_-HASH_-TABLE() - for con in conlist repeat - parents := asyParents con - HPUT($parentsHash,con,asyParents con) --- for [parent,:pred] in parents repeat --- parentOp := opOf parent --- HPUT($childrenHash,parentOp,insert([con,:pred],HGET($childrenHash,parentOp))) - $newConlist := union(conlist, $newConlist) - [[x,:asMakeAlist x] for x in HKEYS $conHash] - -asyParents(conform) == - acc := nil - con:= opOf conform ---formals := TAKE(#formalParams,$TriangleVariableList) - modemap := LASSOC(con,$mmAlist) - $constructorCategory :local := asySubstMapping CADAR modemap - for x in folks $constructorCategory repeat --- x := SUBLISLIS(formalParams,formals,x) --- x := SUBLISLIS(IFCDR conform,formalParams,x) --- x := SUBST('Type,'Object,x) - acc := [:explodeIfs x,:acc] - NREVERSE acc - -asySubstMapping u == - u is [op,:r] => - op = "->" => - [s, t] := r - args := - s is [op,:u] and asyComma? op => [asySubstMapping y for y in u] - [asySubstMapping s] - ['Mapping, asySubstMapping t, :args] - [asySubstMapping x for x in u] - u - ---asyFilePackage asyFile == --- name := INTERN PATHNAME_-NAME asyFile --- modemap := --- [[[name],['CATEGORY,'domain, --- :[asyMkSignature(con,CDAR mm) for [con,:mm] in $mmAlist]]],['T,name]] --- opAlist := [[con,[CDAR mm]] for [con,:mm] in $mmAlist] --- documentation := --- [[con,[CDAR mm,fn LASSOC(con,$docAlist)]] for [con,:mm] in $mmAlist] --- where fn u == --- LASSOC('constructor,u) is [[=nil,doc]] => doc --- '"" --- res := [['constructorForm,name],['constant,:'true], --- ['constructorKind,:'file], --- ['constructorModemap,:modemap], --- ['sourceFile,:PNAME name], --- ['operationAlist,:zeroOneConversion opAlist], --- ['documentation,:documentation]] ---asyDisplay(name,res) --- [name,:res] - -asyMkSignature(con,sig) == --- atom sig => ['TYPE,con,sig] --- following line converts constants into nullary functions - atom sig => ['SIGNATURE,con,[sig]] - ['SIGNATURE,con,sig] - -asMakeAlist con == - record := HGET($conHash,con) - [form,sig,predlist,kind,exposure,comments,typeCode,:filename] := first record ---TTT in case we put the wrong thing in for niladic catgrs ---if ATOM(form) and kind='category then form:=[form] - if ATOM(form) then form:=[form] - kind = 'function => asMakeAlistForFunction con - abb := asyAbbreviation(con,#(KDR sig)) - if null KDR form then PUT(opOf form,'NILADIC,'T) - modemap := asySubstMapping LASSOC(con,$mmAlist) - $constructorCategory :local := CADAR modemap - parents := mySort HGET($parentsHash,con) ---children:= mySort HGET($childrenHash,con) - alists := HGET($opHash,con) - opAlist := SUBLISLIS($FormalMapVariableList,KDR form,CDDR alists) - ancestorAlist:= SUBLISLIS($FormalMapVariableList,KDR form,CAR alists) - catAttrs := [[x,:true] for x in getAttributesFromCATEGORY $constructorCategory] - attributeAlist := REMDUP [:CADR alists,:catAttrs] - documentation := - SUBLISLIS($FormalMapVariableList,KDR form,LASSOC(con,$docAlist)) - filestring := STRCONC(PATHNAME_-NAME STRINGIMAGE filename,'".as") - constantPart := HGET($constantHash,con) and [['constant,:true]] - niladicPart := MEMQ(con,$niladics) and [['NILADIC,:true]] - falist := TAKE(#KDR form,$FormalMapVariableList) - constructorCategory := - kind = 'category => - talist := TAKE(#KDR form, $TriangleVariableList) - SUBLISLIS(talist, falist, $constructorCategory) - SUBLISLIS(falist,KDR form,$constructorCategory) - if constructorCategory='Category then kind := 'category - exportAlist := asGetExports(kind, form, constructorCategory) - constructorModemap := SUBLISLIS(falist,KDR form,modemap) ---TTT fix a niladic category constructormodemap (remove the joins) - if kind = 'category then - SETF(CADAR(constructorModemap),['Category]) - res := [['constructorForm,:form],:constantPart,:niladicPart, - ['constructorKind,:kind], - ['constructorModemap,:constructorModemap], - ['abbreviation,:abb], - ['constructorCategory,:constructorCategory], - ['parents,:parents], - ['attributes,:attributeAlist], - ['ancestors,:ancestorAlist], - -- ['children,:children], - ['sourceFile,:filestring], - ['operationAlist,:zeroOneConversion opAlist], - ['modemaps,:asGetModemaps(exportAlist,form,kind,modemap)], - ['sourcefile,:$asFilename], - ['typeCode,:typeCode], - ['documentation,:documentation]] - if $asyPrint then asyDisplay(con,res) - res - -asGetExports(kind, conform, catform) == - u := asCategoryParts(kind, conform, catform, true) or return nil - -- ensure that signatures are lists - [[op, sigpred] for [op,sig,:pred] in CDDR u] where - sigpred() == - pred := - pred = "T" => nil - pred - [sig, nil, :pred] - -asMakeAlistForFunction fn == - record := HGET($conHash,fn) - [form,sig,predlist,kind,exposure,comments,typeCode,:filename] := first record - modemap := LASSOC(fn,$mmAlist) - newsig := asySignature(sig,nil) - opAlist := [[fn,[newsig,nil,:predlist]]] - res := [['modemaps,:asGetModemaps(opAlist,fn,'function,modemap)], - ['typeCode,:typeCode]] - if $asyPrint then asyDisplay(fn,res) - res - -getAttributesFromCATEGORY catform == - catform is ['CATEGORY,.,:r] => [y for x in r | x is ['ATTRIBUTE,y]] - catform is ['Join,:m,x] => getAttributesFromCATEGORY x - nil - -displayDatabase x == main where - main() == - for y in - '(CONSTRUCTORFORM CONSTRUCTORKIND _ - CONSTRUCTORMODEMAP _ - ABBREVIATION _ - CONSTRUCTORCATEGORY _ - PARENTS _ - ATTRIBUTES _ - ANCESTORS _ - SOURCEFILE _ - OPERATIONALIST _ - MODEMAPS _ - SOURCEFILE _ - DOCUMENTATION) repeat fn(x,y) - where - fn(x,y) == - sayBrightly ['"----------------- ",y,'" --------------------"] - pp GETDATABASE(x,y) - --- For some reason Dick has modified as.boot to convert the --- identifier |0| or |1| to an integer in the list of operations. --- This is WRONG, all existing code assumes that operation names --- are always identifiers not numbers. --- This function breaks the ability of the interpreter to find --- |0| or |1| as exports of new compiler domains. --- Unless someone has a strong reason for keeping the change, --- this function should be no-opped, i.e. --- zeroOneConversion opAlist == opAlist --- If this change is made, then we are able to find asharp constants again. --- bmt Mar 26, 1994 and executed by rss - -zeroOneConversion opAlist == opAlist --- for u in opAlist repeat --- [op,:.] := u --- DIGITP (PNAME op).0 => RPLACA(u, string2Integer PNAME op) --- opAlist - -asyDisplay(con,alist) == - banner := '"==============================" - sayBrightly [banner,'" ",con,'" ",banner] - for [prop,:value] in alist repeat - sayBrightlyNT [prop,'": "] - pp value - -asGetModemaps(opAlist,oform,kind,modemap) == - acc:= nil - rpvl:= - MEMQ(kind, '(category function)) => rest $PatternVariableList -- *1 is special for $ - $PatternVariableList - form := [opOf oform,:[y for x in KDR oform for y in rpvl]] - dc := - MEMQ(kind, '(category function)) => "*1" - form - pred1 := - kind = 'category => [["*1",form]] - nil - signature := CDAR modemap - domainList := - [[a,m] for a in rest form for m in rest signature | - asIsCategoryForm m] - catPredList:= - kind = 'function => [["isFreeFunction","*1",opOf form]] - [['ofCategory,:u] for u in [:pred1,:domainList]] --- for [op,:itemlist] in SUBLISLIS(rpvl, $FormalMapVariableList,opAlist) repeat --- the code seems to oscillate between generating $FormalMapVariableList --- and generating $TriangleVariableList - for [op,:itemlist] in SUBLISLIS(rpvl, $FormalMapVariableList,opAlist) repeat - for [sig0, pred] in itemlist repeat - sig := SUBST(dc,"$",sig0) - pred:= SUBST(dc,"$",pred) - sig := SUBLISLIS(rpvl,KDR oform,sig) - pred:= SUBLISLIS(rpvl,KDR oform,pred) - pred := pred or 'T - ----------> Constants change <-------------- - if IDENTP sig0 then - sig := [sig] - pred := MKPF([pred,'(isAsConstant)],'AND) - pred' := MKPF([pred,:catPredList],'AND) - mm := [[dc,:sig],[pred']] - acc := [[op,:interactiveModemapForm mm],:acc] - NREVERSE acc - -asIsCategoryForm m == - m = 'BasicType or GETDATABASE(opOf m,'CONSTRUCTORKIND) = 'category - -asyDocumentation con == - docHash := HGET($docHash,con) - u := [[op,:[fn(x,op) for x in rec]] for op in HKEYS docHash - | rec := HGET(docHash,op)] where fn(x,op) == - [form,sig,pred,origin,where?,comments,:.] := x - ----------> Constants change <-------------- - if IDENTP sig then sig := [sig] - [asySignature(sig,nil),trimComments comments] - [form,sig,pred,origin,where?,comments] := first HGET($conHash,con) - --above "first" assumes only one entry - comments := trimComments asyExtractDescription comments - [:u,['constructor,[nil,comments]]] - -asyExtractDescription str == - k := STRPOS('"Description:",str,0,nil) => asyExtractDescription SUBSTRING(str,k + 12,nil) - k := STRPOS('"Author:",str,0,nil) => asyExtractDescription SUBSTRING(str,0,k) - str - -trimComments str == - null str or str = '"" => '"" - m := MAXINDEX str - str := SUBSTRING(str,0,m) - trimString str - -asyExportAlist con == ---format of 'operationAlist property of LISPLIBS (as returned from koOps): --- --- ---!!! asyFile NEED: need to know if function is implemented by domain!!! - docHash := HGET($docHash,con) - [[op,:[fn(x,op) for x in rec]] for op in HKEYS docHash | rec := HGET(docHash,op)] - where fn(x,op) == - [form,sig,pred,origin,where?,comments,:.] := x - tail := - pred => [pred] - nil - newSig := asySignature(sig,nil) - [newSig,nil,:tail] - -asyMakeOperationAlist(con,proplist, key) == - oplist := - u := LASSOC('domExports,proplist) => - kind := 'domain - u - u := LASSOC('catExports,proplist) => - kind := 'category - u - key = 'domain => - kind := 'domain - u := NIL - return nil - ht := MAKE_-HASH_-TABLE() - ancestorAlist := nil - for ['Declare,id,form,r] in oplist repeat - id = "%%" => - opOf form = con => nil - y := asyAncestors form - [attrs, na] := asyFindAttrs y - y := na - if opOf(y)^=con then ancestorAlist := [ [y,:true],:ancestorAlist] - idForm := - form is ['Apply,'_-_>,source,target] => [id,:asyArgs source] - ----------> Constants change <-------------- - id - pred := - LASSOC('condition,r) is p => hackToRemoveAnd p - nil - sig := asySignature(asytranForm(form,[idForm],nil),nil) - entry := - --id ^= "%%" and IDENTP idForm => [[sig],nil,nil,'ASCONST] - id ^= "%%" and IDENTP idForm => - pred => [[sig],nil,asyPredTran pred,'ASCONST] - [[sig],nil,true,'ASCONST] - pred => [sig,nil,asyPredTran pred] - [sig] - HPUT(ht,id,[entry,:HGET(ht,id)]) - opalist := [[op,:REMDUP HGET(ht,op)] for op in HKEYS ht] - --HPUT($opHash,con,[ancestorAlist,attributeAlist,:opalist]) -<> - -hackToRemoveAnd p == ----remove this as soon as .asy files do not contain forms (And pred) forms - p is ['And,q,:r] => - r => ['AND,q,:r] - q - p - -asyAncestors x == - x is ['Apply,:r] => asyAncestorList r - x is [op,y,:.] and MEMQ(op, '(PretendTo RestrictTo)) => asyAncestors y - atom x => - x = '_% => '_$ - MEMQ(x, $niladics) => [x] - GETDATABASE(x ,'NILADIC) => [x] - x - asyAncestorList x - -asyAncestorList x == [asyAncestors y for y in x] ---============================================================================ --- Build Operation Alist from sig ---============================================================================ - ---format of operations as returned from koOps --- --- - ---abb,kind,file,sourcefile,coSig,dbLineNumber,constructorArgs,libfile ---((sig where(NIL or #) condition(T or pred) ELTorSubsumed) ... ---expanded lists are: sig, predicate, origin, exposeFlag, comments - ---============================================================================ --- Building Hash Tables for Operations/Constructors ---============================================================================ -asytran fn == ---put operations into table format for browser: --- - inStream := OPEN fn - sayBrightly ['" Reading ",fn] - u := VMREAD inStream - $niladics := mkNiladics u - for x in $niladics repeat PUT(x,'NILADIC,true) - for d in u repeat - ['Declare,name,:.] := d - name = "%%" => 'skip --skip over top-level properties - $docHashLocal: local := MAKE_-HASH_-TABLE() - asytranDeclaration(d,'(top),nil,false) - if null name then hohohoho() - HPUT($docHash,name,$docHashLocal) - CLOSE inStream - 'done - -mkNiladics u == - [name for x in u | x is ['Declare,name,y,:.] and y isnt ['Apply,'_-_>,:.]] - ---OLD DEFINITION FOLLOWS -asytranDeclaration(dform,levels,predlist,local?) == - ['Declare,id,form,r] := dform - id = 'failed => id - KAR dform ^= 'Declare => systemError '"asytranDeclaration" - if levels = '(top) then - if form isnt ['Apply,"->",:.] then HPUT($constantHash,id,true) - comments := LASSOC('documentation,r) or '"" - idForm := - levels is ['top,:.] => - form is ['Apply,'_-_>,source,target] => [id,:asyArgs source] - id - ----------> Constants change <-------------- - id - newsig := asytranForm(form,[idForm,:levels],local?) - key := - levels is ['top,:.] => - MEMQ(id,'(%% Category Type)) => 'constant - asyLooksLikeCatForm? form => 'category - form is ['Apply, '_-_>,.,u] => - if u is ['Apply, construc,:.] then u:= construc - GETDATABASE(opOf u,'CONSTRUCTORKIND) = 'domain => 'function - asyLooksLikeCatForm? u => 'category - 'domain - 'domain - first levels - typeCode := LASSOC('symeTypeCode,r) - record := [idForm,newsig,asyMkpred predlist,key,true,comments,typeCode,:$asyFile] - if not local? then - ht := - levels = '(top) => $conHash - $docHashLocal - HPUT(ht,id,[record,:HGET(ht,id)]) - if levels = '(top) then asyMakeOperationAlist(id,r, key) - ['Declare,id,newsig,r] - -asyLooksLikeCatForm? x == ---TTT don't see a Third in my version .... - x is ['Define, ['Declare, ., ['Apply, 'Third,:.],:.],:.] or - x is ['Define, ['Declare, ., 'Category ],:.] - ---asytranDeclaration(dform,levels,predlist,local?) == --- ['Declare,id,form,r] := dform --- id = 'failed => id --- levels isnt ['top,:.] => asytranForm(form,[id,:levels],local?) --- idForm := --- form is ['Apply,'_-_>,source,target] => [id,:asyArgs source] --- id --- if form isnt ['Apply,"->",:.] then HPUT($constantHash,id,true) --- comments := LASSOC('documentation,r) or '"" --- newsig := asytranForm(form,[idForm,:levels],local?) --- key := --- MEMQ(id,'(%% Category Type)) => 'constant --- form is ['Apply,'Third,:.] => 'category --- form is ['Apply,.,.,target] and target is ['Apply,name,:.] --- and MEMQ(name,'(Third Join)) => 'category --- 'domain --- record := [newsig,asyMkpred predlist,key,true,comments,:$asyFile] --- if not local? then --- ht := --- levels = '(top) => $conHash --- $docHashLocal --- HPUT(ht,id,[record,:HGET(ht,id)]) --- if levels = '(top) then asyMakeOperationAlist(id,r) --- ['Declare,id,newsig,r] - -asyIsCatForm form == - form is ['Apply,:r] => - r is ['_-_>,.,a] => asyIsCatForm a - r is ['Third,'Type,:.] => true - false - false - -asyArgs source == - args := - source is [op,:u] and asyComma? op => u - [source] - [asyArg x for x in args] - -asyArg x == - x is ['Declare,id,:.] => id - x - -asyMkpred predlist == - null predlist => nil - predlist is [p] => p - ['AND,:predlist] - -asytranForm(form,levels,local?) == - u := asytranForm1(form,levels,local?) - null u => hahah() - u - -asytranForm1(form,levels,local?) == - form is ['With,left,cat] => --- left ^= nil => error '"WITH cannot take a left argument yet" - asytranCategory(form,levels,nil,local?) - form is ['Apply,:.] => asytranApply(form,levels,local?) - form is ['Declare,:.] => asytranDeclaration(form,levels,nil,local?) - form is ['Comma,:r] => ['Comma,:[asytranForm(x,levels,local?) for x in r]] ---form is ['_-_>,:s] => asytranMapping(s,levels,local?) - form is [op,a,b] and MEMQ(a,'(PretendTo RestrictTo)) => - asytranForm1(a,levels,local?) - form is ['LitInteger,s] => - READ_-FROM_-STRING(s) - form is ['Define,:.] => - form is ['Define,['Declare,.,x,:.],rest] => ---TTT i don't know about this one but looks ok - x = 'Category => asytranForm1(rest,levels, local?) - asytranForm1(x,levels,local?) - error '"DEFINE forms are not handled yet" - if form = '_% then $hasPerCent := true - IDENTP form => - form = "%" => "$" - GETL(form,'NILADIC) => [form] - form - [asytranForm(x,levels,local?) for x in form] - -asytranApply(['Apply,name,:arglist],levels,local?) == - MEMQ(name,'(Record Union)) => - [name,:[asytranApplySpecial(x, levels, local?) for x in arglist]] - null arglist => [name] - name is [ 'RestrictTo, :.] => - asytranApply(['Apply, CAR CDR name,:arglist], levels, local?) - name is [ 'Qualify, :.] => - asytranApply(['Apply, CAR CDR name,:arglist], levels, local?) - name is 'string => asytranLiteral CAR arglist - name is 'integer => asytranLiteral CAR arglist - name is 'float => asytranLiteral CAR arglist - name = 'Enumeration => - ["Enumeration",:[asytranEnumItem arg for arg in arglist]] - [:argl,lastArg] := arglist - [name,:[asytranFormSpecial(arg,levels,true) for arg in argl], - asytranFormSpecial(lastArg,levels,false)] - -asytranLiteral(lit) == - CAR CDR lit - -asytranEnumItem arg == - arg is ['Declare, name, :.] => name - error '"Bad Enumeration entry" - -asytranApplySpecial(x, levels, local?) == - x is ['Declare, name, typ, :.] => [":",name,asytranForm(typ, levels, local?)] - asytranForm(x, levels, local?) - -asytranFormSpecial(x, levels, local?) == --> this throws away variable name (revise later) - x is ['Declare, name, typ, :.] => asytranForm(typ, levels, local?) - asytranForm(x, levels, local?) - -asytranCategory(form,levels,predlist,local?) == - cat := - form is ['With,left,right] => - right is ['Blank,:.] => ['Sequence] - right - form - left := - form is ['With,left,right] => - left is ['Blank,:.] => nil - left - nil - $hasPerCent: local := nil - items := - cat is ['Sequence,:s] => s - [cat] - catTable := MAKE_-HASH_-TABLE() - catList := nil - for x in items | x repeat - if null x then systemError() - dform := asytranCategoryItem(x,levels,predlist,local?) - null dform => nil - dform is ['Declare,id,record,r] => - HPUT(catTable,id,[asyWrap(record,predlist),:HGET(catTable,id)]) - catList := [asyWrap(dform,predlist),:catList] - keys := listSort(function GLESSEQP,HKEYS catTable) - right1 := NREVERSE catList - right2 := [[key,:HGET(catTable,key)] for key in keys] - right := - right2 => [:right1,['Exports,:right2]] - right1 - res := - left => [left,:right] - right - res is [x] and x is ['IF,:.] => x - ['With,:res] - -asyWrap(record,predlist) == - predlist => ['IF,MKPF(predlist,'AND),record] - record - -asytranCategoryItem(x,levels,predlist,local?) == - x is ['If,predicate,item,:r] => - IFCAR r => error '"ELSE expressions not allowed yet in conditionals" - pred := - predicate is ['Test,r] => r - predicate - asytranCategory(item,levels,[pred,:predlist],local?) - MEMQ(KAR x,'(Default Foreign)) => nil - x is ['Declare,:.] => asytranDeclaration(x,levels,predlist,local?) - x - ---============================================================================ --- Extending Constructor Datatable ---============================================================================ ---FORMAT of $constructorDataTable entry: ---abb kind libFile sourceFile coSig constructorArgs ---alist is ((kind . domain) (libFile . MATRIX) (sourceFile . "matrix") --- (coSig NIL T) (dbLineNumber . 29187) (constructorArgs R) --- (modemap . ( --- (|Matrix| |#1|) --- (Join (MatrixCategory #1 (Vector #1) (Vector #1)) --- (CATEGORY domain --- (SIGNATURE diagonalMatrix ($ (Vector #1))) --- (IF (has #1 (Field)) --- (SIGNATURE inverse ((Union $ "failed") $)) noBranch))) --- (Ring)) --- (T Matrix)) ) -extendConstructorDataTable() == --- tb := $constructorDataTable - for x in listSort(function GLESSEQP,HKEYS $conHash) repeat --- if LASSOC(x,tb) then tb := DELLASOS(x,tb) - record := HGET($conHash,x) - [form,sig,predlist,origin,exposure,comments,typeCode,:filename] := first record - abb := asyAbbreviation(x,#(rest sig)) - kind := 'domain - --Note: this "first" assumes that there is ONLY one sig per name - cosig := [nil,:asyCosig sig] - args := asyConstructorArgs sig - tb := - [[x,abb, - ['kind,:kind], - ['cosig,:cosig], - ['libfile,filename], - ['sourceFile,STRINGIMAGE filename], - ['constructorArgs,:args]],:tb] - listSort(function GLESSEQP,ASSOCLEFT tb) - -asyConstructorArgs sig == - sig is ['With,:.] => nil - sig is ['_-_>,source,target] => - source is [op,:argl] and asyComma? op => [asyConstructorArg x for x in argl] - [asyConstructorArg source] - -asyConstructorArg x == - x is ['Declare,name,t,:.] => name - x - -asyCosig sig == --can be a type or could be a signature - atom sig or sig is ['With,:.] => nil - sig is ['_-_>,source,target] => - source is [op,:argl] and asyComma? op => [asyCosigType x for x in argl] - [asyCosigType source] - error false - -asyCosigType u == - u is [name,t] => - t is [fn,:.] => - asyComma? fn => fn - fn = 'With => 'T - nil - t = 'Type => 'T - error '"Unknown atomic type" - error false - -asyAbbreviation(id,n) == chk(id,main) where --> n = number of arguments - main() == - a := createAbbreviation id => a - name := PNAME id --- #name < 8 => INTERN UPCASE name - parts := asySplit(name,MAXINDEX name) - newname := "STRCONC"/[asyShorten x for x in parts] - #newname < 8 => INTERN newname - tryname := SUBSTRING(name,0,7) - not createAbbreviation tryname => INTERN UPCASE tryname - nil - chk(conname,abb) == - (xx := asyGetAbbrevFromComments conname) => xx - con := abbreviation? abb => - conname = con => abb - conname - abb - -asyGetAbbrevFromComments con == - docHash := HGET($docHash,con) - u := [[op,:[fn(x,op) for x in rec]] for op in HKEYS docHash - | rec := HGET(docHash,op)] where fn(x,op) == - [form,sig,pred,origin,where?,comments,:.] := x - ----------> Constants change <-------------- - if IDENTP sig then sig := [sig] - [asySignature(sig,nil),trimComments comments] - [form,sig,pred,origin,where?,comments] := first HGET($conHash,con) - --above "first" assumes only one entry - x := asyExtractAbbreviation comments - x => intern x - NIL - -asyExtractAbbreviation str == - not (k:= STRPOS('"Abbrev: ",str,0,nil)) => NIL - str := SUBSTRING(str, k+8, nil) - k := STRPOS($stringNewline, str,0,nil) - k => SUBSTRING(str, 0, k) - str - -asyShorten x == - y := createAbbreviation x - or LASSOC(x, - '(("Small" . "SM") ("Single" ."S") ("Half" . "H")("Point" . "PT") - ("Floating" . "F") ("System" . "SYS") ("Number" . "N") - ("Inventor" . "IV") - ("Finite" . "F") ("Double" . "D") ("Builtin" . "BI"))) => y - UPCASE x - -asySplit(name,end) == - end < 1 => [name] - k := 0 - for i in 1..end while LOWER_-CASE_-P name.i repeat k := i - k := k + 1 - [SUBSTRING(name,0,k),:asySplit(SUBSTRING(name,k,nil),end-k)] - -createAbbreviation s == - if STRINGP s then s := INTERN s - a := constructor? s - a ^= s => a - nil - ---============================================================================ --- extending getConstructorModemap Property ---============================================================================ ---Note: modemap property is built when getConstructorModemap is called - -asyConstructorModemap con == - HGET($conHash,con) isnt [record,:.] => nil --not there - [form,sig,predlist,kind,exposure,comments,typeCode,:filename] := record - $kind: local := kind - --NOTE: sig has the form (-> source target) or simply (target) - $constructorArgs: local := KDR form - signature := asySignature(sig,false) - formals := ['_$,:TAKE(#$constructorArgs,$FormalMapVariableList)] - mm := [[[con,:$constructorArgs],:signature],['T,con]] - SUBLISLIS(formals,['_%,:$constructorArgs],mm) - -asySignature(sig,names?) == - sig is ['Join,:.] => [asySig(sig,nil)] - sig is ['With,:.] => [asySig(sig,nil)] - sig is ['_-_>,source,target] => - target := - names? => ['dummy,target] - target - source is [op,:argl] and asyComma? op => - [asySigTarget(target,names?),:[asySig(x,names?) for x in argl]] - [asySigTarget(target,names?),asySig(source,names?)] - ----------> The following is a hack for constants which are category names<-- - sig is ['Third,:.] => [asySig(sig,nil)] - ----------> Constants change <-------------- - asySig(sig,nil) - -asySigTarget(u,name?) == asySig1(u,name?,true) - -asySig(u,name?) == asySig1(u,name?,false) - -asySig1(u,name?,target?) == - x := - name? and u is [name,t] => t - u - x is [fn,:r] => - fn = 'Join => asyTypeJoin r ---------> jump out to newer code 4/94 - MEMQ(fn, '(RestrictTo PretendTo)) => asySig(first r,name?) - asyComma? fn => - u := [asySig(x,name?) for x in r] - target? => - null u => '(Void) - -- this implies a multiple value return, not currently supported - -- in the interpreter - ['Multi,:u] - u - fn = 'With => asyCATEGORY r - fn = 'Third => - r is [b] => - b is ['With,:s] => asyCATEGORY s - b is ['Blank,:.] => asyCATEGORY nil - error x - fn = 'Apply and r is ['_-_>,:s] => asyMapping(s,name?) - fn = '_-_> => asyMapping(r,name?) - fn = 'Declare and r is [name,typ,:.] => - asySig1(typ, name?, target?) - x is '(_%) => '(_$) - [fn,:[asySig(x,name?) for x in r]] ---x = 'Type => '(Type) - x = '_% => '_$ - x - --- old version was : ---asyMapping([a,b],name?) == --- a := asySig(a,name?) --- b := asySig(b,name?) --- args := --- a is [op,:r] and asyComma? op => r --- [a] --- ['Mapping,b,:args] - -asyMapping([a,b],name?) == - newa := asySig(a,name?) - b := asySig(b,name?) - args := - a is [op,:r] and asyComma? op => newa - [a] - ['Mapping,b,:args] - ---============================================================================ --- code for asySignatures of the form (Join,:...) ---============================================================================ -asyType x == - x is [fn,:r] => - fn = 'Join => asyTypeJoin r - MEMQ(fn, '(RestrictTo PretendTo)) => asyType first r - asyComma? fn => - u := [asyType x for x in r] - u - fn = 'With => asyCATEGORY r - fn = '_-_> => asyTypeMapping r - fn = 'Apply => r --- fn = 'Declare and r is [name,typ,:.] => typ - x is '(_%) => '(_$) - x ---x = 'Type => '(Type) - x = '_% => '_$ - x - -asyTypeJoin r == - $conStack : local := nil - $opStack : local := nil - $predlist : local := nil - for x in r repeat asyTypeJoinPart(x,$predlist) - catpart := - $opStack => ['CATEGORY,$kind,:asyTypeJoinStack REVERSE $opStack] - nil - conpart := asyTypeJoinStack REVERSE $conStack - conpart => - catpart => ['Join,:conpart,catpart] - CDR conpart => ['Join,:conpart] - conpart - catpart - -asyTypeJoinPart(x,$predlist) == - x is ['Join,:y] => for z in y repeat asyTypeJoinPart(z, $predlist) - x is ['With,:y] => for p in y repeat asyTypeJoinPartWith p - asyTypeJoinPartWith x - -asyTypeJoinPartWith x == - x is ['Exports,:y] => for p in y repeat asyTypeJoinPartExport p - x is ['Exports,:.] => systemError 'exports - x is ['Comma] => nil - x is ['Export,:y] => nil - x is ['IF,:r] => asyTypeJoinPartIf r - x is ['Sequence,:x] => for y in x repeat asyTypeJoinItem y - asyTypeJoinItem x - -asyTypeJoinPartIf [pred,value] == - predlist := [asyTypeJoinPartPred pred,:$predlist] - asyTypeJoinPart(value,predlist) - -asyTypeJoinPartPred x == - x is ['Test, y] => asyTypeUnit y - asyTypeUnit x - -asyTypeJoinItem x == - result := asyTypeUnit x - isLowerCaseLetter (PNAME opOf result).0 => - $opStack := [[['ATTRIBUTE,result],:$predlist],:$opStack] - $conStack := [[result,:$predlist],:$conStack] - -asyTypeMapping([a,b]) == - a := asyTypeUnit a - b := asyTypeUnit b - args := - a is [op,:r] and asyComma? op => r - [a] - ['Mapping,b,:args] - -asyTypeUnit x == - x is [fn,:r] => - fn = 'Join => systemError 'Join ----->asyTypeJoin r - MEMQ(fn, '(RestrictTo PretendTo)) => asyTypeUnit first r - asyComma? fn => - u := [asyTypeUnit x for x in r] - u - fn = 'With => asyCATEGORY r - fn = '_-_> => asyTypeMapping r - fn = 'Apply => asyTypeUnitList r - fn = 'Declare and r is [name,typ,:.] => asyTypeUnitDeclare(name,typ) - x is '(_%) => '(_$) - [fn,:asyTypeUnitList r] - GETL(x,'NILADIC) => [x] ---x = 'Type => '(Type) - x = '_% => '_$ - x - -asyTypeUnitList x == [asyTypeUnit y for y in x] - -asyTypeUnitDeclare(op,typ) == - typ is ['Apply, :r] => asyCatSignature(op,r) - asyTypeUnit typ ---============================================================================ --- Translator for ['With,:.] ---============================================================================ -asyCATEGORY x == - if x is [join,:y] and join is ['Apply,:s] then - exports := y - joins := - s is ['Join,:r] => [asyJoinPart u for u in r] - [asyJoinPart s] - else if x is [id,:y] and IDENTP id then - joins := [[id]] - exports := y - else - joins := nil - exports := x - cats := exports - operations := nil - if exports is [:r,['Exports,:ops]] then - cats := r - operations := ops - exportPart := - ['CATEGORY,'domain,:"APPEND"/[asyCatItem y for y in operations]] - [attribs, na] := asyFindAttrs joins - joins := na - cats := "append"/[asyCattran c for c in cats] - [a, na] := asyFindAttrs cats - cats := na - attribs := APPEND(attribs, a) - attribs := [['ATTRIBUTE, x] for x in attribs] - exportPart := [:exportPart,:attribs] - joins or cats or attribs => - ['Join,:joins,:cats, exportPart] - exportPart - -asyFindAttrs l == - attrs := [] - notattrs := [] - for x in l repeat - x0 := x - while CONSP x repeat x := CAR x - if MEMQ(x, _*ATTRIBUTES_*) then attrs := [:attrs, x] - else notattrs := [:notattrs, x0] - [attrs, notattrs] - -simpCattran x == - u := asyCattran x - u is [y] => y - ['Join,:u] - -asyCattran x == - x is ['With,:r] => "append"/[asyCattran1 x for x in r] - x is ['IF,:.] => "append"/[asyCattranConstructors(x,nil)] - [x] - -asyCattran1 x == - x is ['Exports,:y] => "append"/[asyCattranOp u for u in y] - x is ['IF,:.] => "append"/[asyCattranConstructors(x,nil)] - systemError nil - -asyCattranOp [op,:items] == - "append"/[asyCattranOp1(op,item,nil) for item in items] - -asyCattranOp1(op, item, predlist) == - item is ['IF, p, x] => - pred := asyPredTran - p is ['Test,t] => t - p --- x is ['IF,:.] => "append"/[asyCattranOp1('IF, x, [pred,:predlist])] --- This line used to call asyCattranOp1 with too few arguments. Following --- fix suggested by RDJ. - x is ['IF,:.] => "append"/[asyCattranOp1(op,y,[pred,:predlist]) for y in x] - [['IF, asySimpPred(pred,predlist), asyCattranSig(op,x), 'noBranch]] - [asyCattranSig(op,item)] - -asyPredTran p == asyPredTran1 asyJoinPart p - -asyPredTran1 p == - p is ['Has,x,y] => ['has,x, simpCattran y] - p is ['Test, q] => asyPredTran1 q - p is [op,:r] and MEMQ(op,'(AND OR NOT)) => - [op,:[asyPredTran1 q for q in r]] - p - -asyCattranConstructors(item, predlist) == - item is ['IF, p, x] => - pred := asyPredTran - p is ['Test,t] => t - p - x is ['IF,:.] => "append"/[asyCattranConstructors(x, [pred,:predlist])] - form := ['ATTRIBUTE, asyJoinPart x] - [['IF, asySimpPred(pred,predlist), form, 'noBranch]] - systemError() - -asySimpPred(p, predlist) == - while predlist is [q,:predlist] repeat p := quickAnd(q,p) - p - -asyCattranSig(op,y) == - y isnt ["->",source,t] => --- ['SIGNATURE, op, asyTypeUnit y] --- following makes constants into nullary functions - ['SIGNATURE, op, [asyTypeUnit y]] - s := - source is ['Comma,:s] => [asyTypeUnit z for z in s] - [asyTypeUnit source] - t := asyTypeUnit t - null t => ['SIGNATURE,op,s] - ['SIGNATURE,op,[t,:s]] - -asyJoinPart x == - IDENTP x => [x] - asytranForm(x,nil,true) - -asyCatItem item == - atom item => [item] - item is ['IF,.,.] => [item] - [op,:sigs] := item - [asyCatSignature(op,sig) for sig in sigs | sig] - -asyCatSignature(op,sig) == - sig is ['_-_>,source,target] => - ['SIGNATURE,op, [asyTypeItem target,:asyUnTuple source]] - ----------> Constants change <-------------- --- ['TYPE,op,asyTypeItem sig] --- following line converts constants into nullary functions - ['SIGNATURE,op,[asyTypeItem sig]] - -asyUnTuple x == - x is [op,:u] and asyComma? op => [asyTypeItem y for y in u] - [asyTypeItem x] - -asyTypeItem x == - atom x => - x = '_% => '_$ - x - x is ['_-_>,a,b] => - ['Mapping,b,:asyUnTuple a] - x is ['Apply,:r] => - r is ['_-_>,a,b] => - ['Mapping,b,:asyUnTuple a] - r is ['Record,:parts] => - ['Record,:[[":",a,b] for ['Declare,a,b,:.] in parts]] - r is ['Segment,:parts] => - ['Segment,:[asyTypeItem x for x in parts]] - asytranApply(x,nil,true) - x is ['Declare,.,t,:.] => asyTypeItem t - x is ['Comma,:args] => - -- this implies a multiple value return, not currently supported - -- in the interpreter - args => ['Multi,:[asyTypeItem y for y in args]] - ['Void] - [asyTypeItem y for y in x] - ---============================================================================ --- Utilities ---============================================================================ -asyComma? op == MEMQ(op,'(Comma Multi)) - - -hput(table,name,value) == - if null name then systemError() - HPUT(table,name,value) - ---============================================================================ --- category parts ---============================================================================ - --- this constructs operation information from a category. --- NB: This is categoryParts, but with the kind supplied by --- an arguments -asCategoryParts(kind,conform,category,:options) == main where - main() == - cons? := IFCAR options --means to include constructors as well - $attrlist: local := nil - $oplist : local := nil - $conslist: local := nil - conname := opOf conform - for x in exportsOf(category) repeat build(x,true) - $attrlist := listSort(function GLESSEQP,$attrlist) - $oplist := listSort(function GLESSEQP,$oplist) - res := [$attrlist,:$oplist] - if cons? then res := [listSort(function GLESSEQP,$conslist),:res] - if kind = 'category then - tvl := TAKE(#rest conform,$TriangleVariableList) - res := SUBLISLIS($FormalMapVariableList,tvl,res) - res - where - build(item,pred) == - item is ['SIGNATURE,op,sig,:.] => $oplist := [[opOf op,sig,:pred],:$oplist] - --note: opOf is needed!!! Bug in compiler puts in (One) and (Zero) - item is ['ATTRIBUTE,attr] => - constructor? opOf attr => - $conslist := [[attr,:pred],:$conslist] - nil - opOf attr = 'nothing => 'skip - $attrlist := [[opOf attr,IFCDR attr,:pred],:$attrlist] - item is ['TYPE,op,type] => - $oplist := [[op,[type],:pred],:$oplist] - item is ['IF,pred1,s1,s2] => - build(s1,quickAnd(pred,pred1)) - s2 => build(s2,quickAnd(pred,['NOT,pred1])) - item is ['PROGN,:r] => for x in r repeat build(x,pred) - item in '(noBranch) => 'ok - null item => 'ok - systemError '"build error" - exportsOf(target) == - target is ['CATEGORY,.,:r] => r - target is ['Join,:r,f] => - for x in r repeat $conslist := [[x,:true],:$conslist] - exportsOf f - $conslist := [[target,:true],:$conslist] - nil - ---============================================================================ --- Dead Code (for a very odd value of 'dead') ---============================================================================ -asyTypeJoinPartExport x == - [op,:items] := x - for y in items repeat - y isnt ["->",source,t] => --- sig := ['TYPE, op, asyTypeUnit y] --- converts constants to nullary functions (this code isn't dead) - sig := ['SIGNATURE, op, [asyTypeUnit y]] - $opStack := [[sig,:$predlist],:$opStack] - s := - source is ['Comma,:s] => [asyTypeUnit z for z in s] - [asyTypeUnit source] - t := asyTypeUnit t - sig := - null t => ['SIGNATURE,op,s] - ['SIGNATURE,op,[t,:s]] - $opStack := [[sig,:$predlist],:$opStack] - ---============================================================================ --- Code to create opDead Code ---============================================================================ -asyTypeJoinStack r == - al := [[[x while r is [[x, :q],:s] and p = q and (r := s; true)],:p] - while r is [[.,:p],:.]] - result := "append"/[fn for [y,:p] in al] where fn() == - p => [['IF,asyTypeMakePred p,:y]] - y - result - -asyTypeMakePred [p,:u] == - while u is [q,:u] repeat p := quickAnd(q,p) - p - - - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/ax.boot b/src/interp/ax.boot new file mode 100644 index 00000000..950d9307 --- /dev/null +++ b/src/interp/ax.boot @@ -0,0 +1,385 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- 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. + + +import '"as" +)package "BOOT" + +$stripTypes := false +$pretendFlag := false +$defaultFlag := false +$baseForms := nil +$literals := nil + +spad2AxTranslatorAutoloadOnceTrigger any == true + +sourceFilesToAxFile(filename, sourceFiles) == + makeAxFile(filename, MAPCAN('fileConstructors, sourceFiles)) + + +$extendedDomains := nil + +setExtendedDomains(l) == + $extendedDomains := l + +fileConstructors name == + [INTERN(con,"BOOT") for con in SRCABBREVS SOURCEPATH STRING name] + +makeAxFile(filename, constructors) == + $defaultFlag : local := false + $literals := [] + axForms := + [modemapToAx(modemap) for cname in constructors | + (modemap:=GETDATABASE(cname,'CONSTRUCTORMODEMAP)) and + (not cname in '(Tuple Exit Type)) and + not isDefaultPackageName cname] + if $baseForms then + axForms := [:$baseForms, :axForms] + if $defaultFlag then + axForms := + [['Foreign, ['Declare, 'dummyDefault, 'Exit], 'Lisp], :axForms] + axForms := APPEND(axDoLiterals(), axForms) + axForm := ['Sequence, _ + ['Import, [], 'AxiomLib], ['Import, [], 'Boolean], :axForms] + st := MAKE_-OUTSTREAM(filename) + PPRINT(axForm,st) + CLOSE st + +makeAxExportForm(filename, constructors) == + $defaultFlag : local := false + $literals := [] + axForms := + [modemapToAx(modemap) for cname in constructors | + (modemap:=GETDATABASE(cname,'CONSTRUCTORMODEMAP)) and + (not cname in '(Tuple Exit Type)) and + not isDefaultPackageName cname] + if $baseForms then + axForms := [:$baseForms, :axForms] + if $defaultFlag then + axForms := + [['Foreign, ['Declare, 'dummyDefault, 'Exit], 'Lisp], :axForms] + axForms := APPEND(axDoLiterals(), axForms) + axForm := ['Sequence, _ + ['Import, [], 'AxiomLib], ['Import, [], 'Boolean], :axForms] + axForm + + +stripType type == + $stripTypes => + categoryForm? type => 'Type + type + type + +modemapToAx(modemap) == + modemap is [[consform, target,:argtypes],.] + consform is [constructor,:args] + argdecls:=['Comma, : [axFormatDecl(a,stripType t) for a in args for t in argtypes]] + resultType := axFormatType stripType target + categoryForm? constructor => + categoryInfo := GETDATABASE(constructor,'CONSTRUCTORCATEGORY) + categoryInfo := SUBLISLIS($FormalMapVariableList, $TriangleVariableList, + categoryInfo) + NULL args => + ['Define,['Declare, constructor,'Category], + addDefaults(constructor, axFormatType categoryInfo)] + ['Define, + ['Declare, constructor, ['Apply, "->", optcomma argdecls, 'Category]], + ['Lambda, argdecls, 'Category, + ['Label, constructor, + addDefaults(constructor, axFormatType categoryInfo)]]] + constructor in $extendedDomains => + NULL args => + ['Extend, ['Define, ['Declare, constructor, resultType], + ['Add, ['PretendTo, ['Add, [], []], resultType], []]]] + conscat := INTERN(STRCONC(SYMBOL_-NAME(constructor), "ExtendCategory"),"BOOT") + rtype := ['Apply, conscat, :args] +-- if resultType is ['With,a,b] then +-- if not(b is ['Sequence,:withseq]) then withseq := [b] +-- cosigs := rest GETDATABASE(constructor, 'COSIG) +-- exportargs := [['Export, [], arg, []] for arg in args for p in cosigs | p] +-- resultType := ['With,a,['Sequence,:APPEND(exportargs, withseq)]] + consdef := ['Define, + ['Declare, conscat, ['Apply, "->", optcomma argdecls, 'Category]], + ['Lambda, argdecls, 'Category, ['Label, conscat, resultType]]] + ['Sequence, consdef, + ['Extend, ['Define, + ['Declare, constructor, ['Apply, "->", optcomma argdecls, rtype]], + ['Lambda, argdecls, rtype, + ['Label, constructor, + ['Add, ['PretendTo, ['Add, [], []], rtype], []]]]]]] + NULL args => + ['Export, ['Declare, constructor, resultType],[],[]] +-- if resultType is ['With,a,b] then +-- if not(b is ['Sequence,:withseq]) then withseq := [b] +-- cosigs := rest GETDATABASE(constructor, 'COSIG) +-- exportargs := [['Export, [], arg, []] for arg in args for p in cosigs | p] +-- resultType := ['With,a,['Sequence,:APPEND(exportargs, withseq)]] + ['Export, ['Declare, constructor, ['Apply, "->", optcomma argdecls, resultType]],[],[]] + +optcomma [op,:args] == + # args = 1 => first args + [op,:args] + +axFormatDecl(sym, type) == + if sym = '$ then sym := '% + opOf type in '(StreamAggregate FiniteLinearAggregate) => + ['Declare, sym, 'Type] + ['Declare, sym, axFormatType type] + +makeTypeSequence l == + ['Sequence,: delete('Type, l)] + +axFormatAttrib(typeform) == + atom typeform => typeform + axFormatType typeform + +axFormatType(typeform) == + atom typeform => + typeform = '$ => '% + STRINGP typeform => + ['Apply,'Enumeration, INTERN typeform] + INTEGERP typeform => + -- need to test for PositiveInteger vs Integer + axAddLiteral('integer, 'PositiveInteger, 'Literal) + ['RestrictTo, ['LitInteger, STRINGIMAGE typeform ], 'PositiveInteger] + FLOATP typeform => ['LitFloat, STRINGIMAGE typeform] + MEMQ(typeform,$TriangleVariableList) => + SUBLISLIS($FormalMapVariableList, $TriangleVariableList, typeform) + MEMQ(typeform, $FormalMapVariableList) => typeform + axAddLiteral('string, 'Symbol, 'Literal) + ['RestrictTo, ['LitString, PNAME typeform], 'Symbol] + typeform is ['construct,: args] => + axAddLiteral('bracket, ['Apply, 'List, 'Symbol], [ 'Apply, 'Tuple, 'Symbol]) + axAddLiteral('string, 'Symbol, 'Literal) + ['RestrictTo, ['Apply, 'bracket, + :[axFormatType a for a in args]], + ['Apply, 'List, 'Symbol] ] + typeform is [op] => + op = '$ => '% + op = 'Void => ['Comma] + op + typeform is ['local, val] => axFormatType val + typeform is ['QUOTE, val] => axFormatType val + typeform is ['Join,:cats,lastcat] => + lastcat is ['CATEGORY,type,:ops] => + ['With, [], + makeTypeSequence( + APPEND([axFormatType c for c in cats], + [axFormatOp op for op in ops]))] + ['With, [], makeTypeSequence([axFormatType c for c in rest typeform])] + typeform is ['CATEGORY, type, :ops] => + ['With, [], axFormatOpList ops] + typeform is ['Mapping, target, :argtypes] => + ['Apply, "->", + ['Comma, :[axFormatType t for t in argtypes]], + axFormatType target] + typeform is ['_:, name, type] => axFormatDecl(name,type) + typeform is ['Union, :args] => + first args is ['_:,.,.] => + ['Apply, 'Union, :[axFormatType a for a in args]] + taglist := [] + valueCount := 0 + for x in args repeat + tag := + STRINGP x => INTERN x + x is ['QUOTE,val] and STRINGP val => INTERN val + valueCount := valueCount + 1 + INTERNL("value", STRINGIMAGE valueCount) + taglist := [tag ,: taglist] + ['Apply, 'Union, :[axFormatDecl(name,type) for name in reverse taglist + for type in args]] + typeform is ['Dictionary,['Record,:args]] => + ['Apply, 'Dictionary, + ['PretendTo, axFormatType CADR typeform, 'SetCategory]] + typeform is ['FileCategory,xx,['Record,:args]] => + ['Apply, 'FileCategory, axFormatType xx, + ['PretendTo, axFormatType CADDR typeform, 'SetCategory]] + typeform is [op,:args] => + $pretendFlag and constructor? op and + GETDATABASE(op,'CONSTRUCTORMODEMAP) is [[.,target,:argtypes],.] => + ['Apply, op, + :[['PretendTo, axFormatType a, axFormatType t] + for a in args for t in argtypes]] + MEMQ(op, '(SquareMatrix SquareMatrixCategory DirectProduct + DirectProductCategory RadixExpansion)) and + GETDATABASE(op,'CONSTRUCTORMODEMAP) is [[.,target,arg1type,:restargs],.] => + ['Apply, op, + ['PretendTo, axFormatType first args, axFormatType arg1type], + :[axFormatType a for a in rest args]] + ['Apply, op, :[axFormatType a for a in args]] + error "unknown entry type" + +axFormatOpList ops == ['Sequence,:[axFormatOp o for o in ops]] + +axOpTran(name) == + ATOM name => + name = 'elt => 'apply + name = 'setelt => 'set_! + name = 'SEGMENT => ".." + name = 1 => '_1 + name = 0 => '_0 + name + opOf name = 'Zero => '_0 + opOf name = 'One => '_1 + error "bad op name" + +axFormatOpSig(name, [result,:argtypes]) == + ['Declare, axOpTran name, + ['Apply, "->", ['Comma, :[axFormatType t for t in argtypes]], + axFormatType result]] + +axFormatConstantOp(name, [result]) == + ['Declare, axOpTran name, axFormatType result] + +axFormatPred pred == + atom pred => pred + [op,:args] := pred + op = 'IF => axFormatOp pred + op = 'has => + [name,type] := args + if name = '$ then name := '% + else name := axFormatOp name + ftype := axFormatOp type + if ftype is ['Declare,:.] then + ftype := ['With, [], ftype] + ['Test,['Has,name, ftype]] + axArglist := [axFormatPred arg for arg in args] + op = 'AND => ['And,:axArglist] + op = 'OR => ['Or,:axArglist] + op = 'NOT => ['Not,:axArglist] + error "unknown predicate" + + +axFormatCondOp op == + $pretendFlag:local := true + axFormatOp op + + +axFormatOp op == + op is ['IF, pred, trueops, falseops] => + NULL(trueops) or trueops='noBranch => + ['If, ['Test,['Not, axFormatPred pred]], + axFormatCondOp falseops, + axFormatCondOp trueops] + ['If, axFormatPred pred, + axFormatCondOp trueops, + axFormatCondOp falseops] + -- ops are either single op or ['PROGN, ops] + op is ['SIGNATURE, name, type] => axFormatOpSig(name,type) + op is ['SIGNATURE, name, type, 'constant] => + axFormatConstantOp(name,type) + op is ['ATTRIBUTE, attributeOrCategory] => + categoryForm? attributeOrCategory => + axFormatType attributeOrCategory + ['RestrictTo, axFormatAttrib attributeOrCategory, 'Category] + op is ['PROGN, :ops] => axFormatOpList ops + op is 'noBranch => [] + axFormatType op + +addDefaults(catname, withform) == + withform isnt ['With, joins, ['Sequence,: oplist]] => + error "bad category body" + null(defaults := getDefaultingOps catname) => withform + defaultdefs := [makeDefaultDef(decl) for decl in defaults] + ['With, joins, + ['Sequence, :oplist, ['Default, ['Sequence,: defaultdefs]]]] + +makeDefaultDef(decl) == + decl isnt ['Declare, op, type] => + error "bad default definition" + $defaultFlag := true + type is ['Apply, "->", args, result] => + ['Define, decl, ['Lambda, makeDefaultArgs args, result, + ['Label, op, 'dummyDefault]]] + ['Define, ['Declare, op, type], 'dummyDefault] + +makeDefaultArgs args == + args isnt ['Comma,:argl] => error "bad default argument list" + ['Comma,: [['Declare,v,t] for v in $TriangleVariableList for t in argl]] + +getDefaultingOps catname == + not(name:=hasDefaultPackage catname) => nil + $infovec: local := getInfovec name + opTable := $infovec.1 + $opList:local := nil + for i in 0..MAXINDEX opTable repeat + op := opTable.i + i := i + 1 + startIndex := opTable.i + stopIndex := + i + 1 > MAXINDEX opTable => MAXINDEX getCodeVector() + opTable.(i + 2) + curIndex := startIndex + while curIndex < stopIndex repeat + curIndex := get1defaultOp(op,curIndex) + $pretendFlag : local := true + catops := GETDATABASE(catname, 'OPERATIONALIST) + [axFormatDefaultOpSig(op,sig,catops) for opsig in $opList | opsig is [op,sig]] + +axFormatDefaultOpSig(op, sig, catops) == + #sig > 1 => axFormatOpSig(op,sig) + nsig := MSUBST('$,'($), sig) -- dcSig listifies '$ ?? + (catsigs := LASSOC(op, catops)) and + (catsig := assoc(nsig, catsigs)) and last(catsig) = 'CONST => + axFormatConstantOp(op, sig) + axFormatOpSig(op,sig) + +get1defaultOp(op,index) == + numvec := getCodeVector() + segment := getOpSegment index + numOfArgs := numvec.index + index := index + 1 + predNumber := numvec.index + index := index + 1 + signumList := + -- following substitution fixes the problem that default packages + -- have $ added as a first arg, thus other arg counts are off by 1. + SUBLISLIS($FormalMapVariableList, rest $FormalMapVariableList, + dcSig(numvec,index,numOfArgs)) + index := index + numOfArgs + 1 + slotNumber := numvec.index + if not([op,signumList] in $opList) then + $opList := [[op,signumList],:$opList] + index + 1 + +axAddLiteral(name, type, dom) == + elt := [name, type, dom] + if not member( elt, $literals) then + $literals := [elt, :$literals] + +axDoLiterals() == + [ [ 'Import, + [ 'With, [], + ['Declare, name, [ 'Apply, '_-_> , dom , '_% ]]], + type ] for [name, type, dom] in $literals] + diff --git a/src/interp/ax.boot.pamphlet b/src/interp/ax.boot.pamphlet deleted file mode 100644 index 1063d366..00000000 --- a/src/interp/ax.boot.pamphlet +++ /dev/null @@ -1,431 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp ax.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{New Aldor compiler changes} -This was changed so the open source version of axiom can work with the new -aldor compiler. -This used to read: -\begin{verbatim} - axForm := ['Sequence, ['Import, [], 'AxiomLib], :axForms] -\end{verbatim} -but was changed to read: -<>= - axForm := ['Sequence, _ - ['Import, [], 'AxiomLib], ['Import, [], 'Boolean], :axForms] -@ -\subsection{makeAxExportForm} -<>= -makeAxExportForm(filename, constructors) == - $defaultFlag : local := false - $literals := [] - axForms := - [modemapToAx(modemap) for cname in constructors | - (modemap:=GETDATABASE(cname,'CONSTRUCTORMODEMAP)) and - (not cname in '(Tuple Exit Type)) and - not isDefaultPackageName cname] - if $baseForms then - axForms := [:$baseForms, :axForms] - if $defaultFlag then - axForms := - [['Foreign, ['Declare, 'dummyDefault, 'Exit], 'Lisp], :axForms] - axForms := APPEND(axDoLiterals(), axForms) - axForm := ['Sequence, _ - ['Import, [], 'AxiomLib], ['Import, [], 'Boolean], :axForms] - axForm - -@ -\subsection{axFormatPref} -Here we add an else clause. The original code read: -\begin{verbatim} - if name = '$ then name := '% -\end{verbatim} -It appears that Aldor allows a richer syntax for [[has]] -conditions since the call to [[axFormatOp]] appears to allow -nested IF conditions.OQ -<>= -axFormatPred pred == - atom pred => pred - [op,:args] := pred - op = 'IF => axFormatOp pred - op = 'has => - [name,type] := args - if name = '$ then name := '% - else name := axFormatOp name - ftype := axFormatOp type - if ftype is ['Declare,:.] then - ftype := ['With, [], ftype] - ['Test,['Has,name, ftype]] - axArglist := [axFormatPred arg for arg in args] - op = 'AND => ['And,:axArglist] - op = 'OR => ['Or,:axArglist] - op = 'NOT => ['Not,:axArglist] - error "unknown predicate" - -@ -\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. - -@ -<<*>>= -<> - -import '"as" -)package "BOOT" - -$stripTypes := false -$pretendFlag := false -$defaultFlag := false -$baseForms := nil -$literals := nil - -spad2AxTranslatorAutoloadOnceTrigger any == true - -sourceFilesToAxFile(filename, sourceFiles) == - makeAxFile(filename, MAPCAN('fileConstructors, sourceFiles)) - - -$extendedDomains := nil - -setExtendedDomains(l) == - $extendedDomains := l - -fileConstructors name == - [INTERN(con,"BOOT") for con in SRCABBREVS SOURCEPATH STRING name] - -makeAxFile(filename, constructors) == - $defaultFlag : local := false - $literals := [] - axForms := - [modemapToAx(modemap) for cname in constructors | - (modemap:=GETDATABASE(cname,'CONSTRUCTORMODEMAP)) and - (not cname in '(Tuple Exit Type)) and - not isDefaultPackageName cname] - if $baseForms then - axForms := [:$baseForms, :axForms] - if $defaultFlag then - axForms := - [['Foreign, ['Declare, 'dummyDefault, 'Exit], 'Lisp], :axForms] - axForms := APPEND(axDoLiterals(), axForms) -<> - st := MAKE_-OUTSTREAM(filename) - PPRINT(axForm,st) - CLOSE st - -<> - -stripType type == - $stripTypes => - categoryForm? type => 'Type - type - type - -modemapToAx(modemap) == - modemap is [[consform, target,:argtypes],.] - consform is [constructor,:args] - argdecls:=['Comma, : [axFormatDecl(a,stripType t) for a in args for t in argtypes]] - resultType := axFormatType stripType target - categoryForm? constructor => - categoryInfo := GETDATABASE(constructor,'CONSTRUCTORCATEGORY) - categoryInfo := SUBLISLIS($FormalMapVariableList, $TriangleVariableList, - categoryInfo) - NULL args => - ['Define,['Declare, constructor,'Category], - addDefaults(constructor, axFormatType categoryInfo)] - ['Define, - ['Declare, constructor, ['Apply, "->", optcomma argdecls, 'Category]], - ['Lambda, argdecls, 'Category, - ['Label, constructor, - addDefaults(constructor, axFormatType categoryInfo)]]] - constructor in $extendedDomains => - NULL args => - ['Extend, ['Define, ['Declare, constructor, resultType], - ['Add, ['PretendTo, ['Add, [], []], resultType], []]]] - conscat := INTERN(STRCONC(SYMBOL_-NAME(constructor), "ExtendCategory"),"BOOT") - rtype := ['Apply, conscat, :args] --- if resultType is ['With,a,b] then --- if not(b is ['Sequence,:withseq]) then withseq := [b] --- cosigs := rest GETDATABASE(constructor, 'COSIG) --- exportargs := [['Export, [], arg, []] for arg in args for p in cosigs | p] --- resultType := ['With,a,['Sequence,:APPEND(exportargs, withseq)]] - consdef := ['Define, - ['Declare, conscat, ['Apply, "->", optcomma argdecls, 'Category]], - ['Lambda, argdecls, 'Category, ['Label, conscat, resultType]]] - ['Sequence, consdef, - ['Extend, ['Define, - ['Declare, constructor, ['Apply, "->", optcomma argdecls, rtype]], - ['Lambda, argdecls, rtype, - ['Label, constructor, - ['Add, ['PretendTo, ['Add, [], []], rtype], []]]]]]] - NULL args => - ['Export, ['Declare, constructor, resultType],[],[]] --- if resultType is ['With,a,b] then --- if not(b is ['Sequence,:withseq]) then withseq := [b] --- cosigs := rest GETDATABASE(constructor, 'COSIG) --- exportargs := [['Export, [], arg, []] for arg in args for p in cosigs | p] --- resultType := ['With,a,['Sequence,:APPEND(exportargs, withseq)]] - ['Export, ['Declare, constructor, ['Apply, "->", optcomma argdecls, resultType]],[],[]] - -optcomma [op,:args] == - # args = 1 => first args - [op,:args] - -axFormatDecl(sym, type) == - if sym = '$ then sym := '% - opOf type in '(StreamAggregate FiniteLinearAggregate) => - ['Declare, sym, 'Type] - ['Declare, sym, axFormatType type] - -makeTypeSequence l == - ['Sequence,: delete('Type, l)] - -axFormatAttrib(typeform) == - atom typeform => typeform - axFormatType typeform - -axFormatType(typeform) == - atom typeform => - typeform = '$ => '% - STRINGP typeform => - ['Apply,'Enumeration, INTERN typeform] - INTEGERP typeform => - -- need to test for PositiveInteger vs Integer - axAddLiteral('integer, 'PositiveInteger, 'Literal) - ['RestrictTo, ['LitInteger, STRINGIMAGE typeform ], 'PositiveInteger] - FLOATP typeform => ['LitFloat, STRINGIMAGE typeform] - MEMQ(typeform,$TriangleVariableList) => - SUBLISLIS($FormalMapVariableList, $TriangleVariableList, typeform) - MEMQ(typeform, $FormalMapVariableList) => typeform - axAddLiteral('string, 'Symbol, 'Literal) - ['RestrictTo, ['LitString, PNAME typeform], 'Symbol] - typeform is ['construct,: args] => - axAddLiteral('bracket, ['Apply, 'List, 'Symbol], [ 'Apply, 'Tuple, 'Symbol]) - axAddLiteral('string, 'Symbol, 'Literal) - ['RestrictTo, ['Apply, 'bracket, - :[axFormatType a for a in args]], - ['Apply, 'List, 'Symbol] ] - typeform is [op] => - op = '$ => '% - op = 'Void => ['Comma] - op - typeform is ['local, val] => axFormatType val - typeform is ['QUOTE, val] => axFormatType val - typeform is ['Join,:cats,lastcat] => - lastcat is ['CATEGORY,type,:ops] => - ['With, [], - makeTypeSequence( - APPEND([axFormatType c for c in cats], - [axFormatOp op for op in ops]))] - ['With, [], makeTypeSequence([axFormatType c for c in rest typeform])] - typeform is ['CATEGORY, type, :ops] => - ['With, [], axFormatOpList ops] - typeform is ['Mapping, target, :argtypes] => - ['Apply, "->", - ['Comma, :[axFormatType t for t in argtypes]], - axFormatType target] - typeform is ['_:, name, type] => axFormatDecl(name,type) - typeform is ['Union, :args] => - first args is ['_:,.,.] => - ['Apply, 'Union, :[axFormatType a for a in args]] - taglist := [] - valueCount := 0 - for x in args repeat - tag := - STRINGP x => INTERN x - x is ['QUOTE,val] and STRINGP val => INTERN val - valueCount := valueCount + 1 - INTERNL("value", STRINGIMAGE valueCount) - taglist := [tag ,: taglist] - ['Apply, 'Union, :[axFormatDecl(name,type) for name in reverse taglist - for type in args]] - typeform is ['Dictionary,['Record,:args]] => - ['Apply, 'Dictionary, - ['PretendTo, axFormatType CADR typeform, 'SetCategory]] - typeform is ['FileCategory,xx,['Record,:args]] => - ['Apply, 'FileCategory, axFormatType xx, - ['PretendTo, axFormatType CADDR typeform, 'SetCategory]] - typeform is [op,:args] => - $pretendFlag and constructor? op and - GETDATABASE(op,'CONSTRUCTORMODEMAP) is [[.,target,:argtypes],.] => - ['Apply, op, - :[['PretendTo, axFormatType a, axFormatType t] - for a in args for t in argtypes]] - MEMQ(op, '(SquareMatrix SquareMatrixCategory DirectProduct - DirectProductCategory RadixExpansion)) and - GETDATABASE(op,'CONSTRUCTORMODEMAP) is [[.,target,arg1type,:restargs],.] => - ['Apply, op, - ['PretendTo, axFormatType first args, axFormatType arg1type], - :[axFormatType a for a in rest args]] - ['Apply, op, :[axFormatType a for a in args]] - error "unknown entry type" - -axFormatOpList ops == ['Sequence,:[axFormatOp o for o in ops]] - -axOpTran(name) == - ATOM name => - name = 'elt => 'apply - name = 'setelt => 'set_! - name = 'SEGMENT => ".." - name = 1 => '_1 - name = 0 => '_0 - name - opOf name = 'Zero => '_0 - opOf name = 'One => '_1 - error "bad op name" - -axFormatOpSig(name, [result,:argtypes]) == - ['Declare, axOpTran name, - ['Apply, "->", ['Comma, :[axFormatType t for t in argtypes]], - axFormatType result]] - -axFormatConstantOp(name, [result]) == - ['Declare, axOpTran name, axFormatType result] - -<> - -axFormatCondOp op == - $pretendFlag:local := true - axFormatOp op - - -axFormatOp op == - op is ['IF, pred, trueops, falseops] => - NULL(trueops) or trueops='noBranch => - ['If, ['Test,['Not, axFormatPred pred]], - axFormatCondOp falseops, - axFormatCondOp trueops] - ['If, axFormatPred pred, - axFormatCondOp trueops, - axFormatCondOp falseops] - -- ops are either single op or ['PROGN, ops] - op is ['SIGNATURE, name, type] => axFormatOpSig(name,type) - op is ['SIGNATURE, name, type, 'constant] => - axFormatConstantOp(name,type) - op is ['ATTRIBUTE, attributeOrCategory] => - categoryForm? attributeOrCategory => - axFormatType attributeOrCategory - ['RestrictTo, axFormatAttrib attributeOrCategory, 'Category] - op is ['PROGN, :ops] => axFormatOpList ops - op is 'noBranch => [] - axFormatType op - -addDefaults(catname, withform) == - withform isnt ['With, joins, ['Sequence,: oplist]] => - error "bad category body" - null(defaults := getDefaultingOps catname) => withform - defaultdefs := [makeDefaultDef(decl) for decl in defaults] - ['With, joins, - ['Sequence, :oplist, ['Default, ['Sequence,: defaultdefs]]]] - -makeDefaultDef(decl) == - decl isnt ['Declare, op, type] => - error "bad default definition" - $defaultFlag := true - type is ['Apply, "->", args, result] => - ['Define, decl, ['Lambda, makeDefaultArgs args, result, - ['Label, op, 'dummyDefault]]] - ['Define, ['Declare, op, type], 'dummyDefault] - -makeDefaultArgs args == - args isnt ['Comma,:argl] => error "bad default argument list" - ['Comma,: [['Declare,v,t] for v in $TriangleVariableList for t in argl]] - -getDefaultingOps catname == - not(name:=hasDefaultPackage catname) => nil - $infovec: local := getInfovec name - opTable := $infovec.1 - $opList:local := nil - for i in 0..MAXINDEX opTable repeat - op := opTable.i - i := i + 1 - startIndex := opTable.i - stopIndex := - i + 1 > MAXINDEX opTable => MAXINDEX getCodeVector() - opTable.(i + 2) - curIndex := startIndex - while curIndex < stopIndex repeat - curIndex := get1defaultOp(op,curIndex) - $pretendFlag : local := true - catops := GETDATABASE(catname, 'OPERATIONALIST) - [axFormatDefaultOpSig(op,sig,catops) for opsig in $opList | opsig is [op,sig]] - -axFormatDefaultOpSig(op, sig, catops) == - #sig > 1 => axFormatOpSig(op,sig) - nsig := MSUBST('$,'($), sig) -- dcSig listifies '$ ?? - (catsigs := LASSOC(op, catops)) and - (catsig := assoc(nsig, catsigs)) and last(catsig) = 'CONST => - axFormatConstantOp(op, sig) - axFormatOpSig(op,sig) - -get1defaultOp(op,index) == - numvec := getCodeVector() - segment := getOpSegment index - numOfArgs := numvec.index - index := index + 1 - predNumber := numvec.index - index := index + 1 - signumList := - -- following substitution fixes the problem that default packages - -- have $ added as a first arg, thus other arg counts are off by 1. - SUBLISLIS($FormalMapVariableList, rest $FormalMapVariableList, - dcSig(numvec,index,numOfArgs)) - index := index + numOfArgs + 1 - slotNumber := numvec.index - if not([op,signumList] in $opList) then - $opList := [[op,signumList],:$opList] - index + 1 - -axAddLiteral(name, type, dom) == - elt := [name, type, dom] - if not member( elt, $literals) then - $literals := [elt, :$literals] - -axDoLiterals() == - [ [ 'Import, - [ 'With, [], - ['Declare, name, [ 'Apply, '_-_> , dom , '_% ]]], - type ] for [name, type, dom] in $literals] - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/bc-matrix.boot b/src/interp/bc-matrix.boot index 64d6ffb9..0f8fe3f7 100644 --- a/src/interp/bc-matrix.boot +++ b/src/interp/bc-matrix.boot @@ -1,5 +1,7 @@ -- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are diff --git a/src/interp/bc-misc.boot b/src/interp/bc-misc.boot new file mode 100644 index 00000000..8ef492b3 --- /dev/null +++ b/src/interp/bc-misc.boot @@ -0,0 +1,929 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- 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. + + +import '"bc-util" +)package "BOOT" + +--Hypertex commands other than solve and matrix + +bcDrawIt2(ind,a,b) == STRCONC('"{}",ind,'"=",a,'"{}..",b,'"{}") + +bcIndefiniteIntegrate() == + htInitPage("Indefinite Integration Basic Command",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain S (String)) + (isDomain SY (Symbol))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em function} you would like to integrate:") + (text . "\newline\tab{2} ") + (bcStrings (45 "1/(x**2 + 6)" integrand EM)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em variable of integration}:") + (text . "\tab{37}") + (bcStrings (10 x symbol SY)) + (doneButton "Continue" bcIndefiniteIntegrateGen)) + htShowPage() + +bcIndefiniteIntegrateGen htPage == + integrand := htpLabelInputString(htPage,'integrand) + var := htpLabelInputString(htPage,'symbol) + bcGen STRCONC('"integrate(",integrand,'",",var,")") + + +bcDefiniteIntegrate() == + htInitPage("Definite Integration Basic Command",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain S (String)) + (isDomain SY (Symbol))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em function} you would like to integrate:") + (text . "\newline\tab{2} ") + (bcStrings (45 "1/(x**2 + 6)" integrand EM)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em variable of integration}:") + (text . "\tab{37}") + (bcStrings (10 x symbol SY)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "\newline Enter {\em lower limit}:") + (radioButtons fromButton + ("" "Minus infinity" minusInfinity) + ("" ( + (text . "A finite point:\tab{15}") + (bcStrings (10 0 from EM . bcOptional))) fromPoint)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "\indent{2}\newline Enter {\em upper limit}:") + (radioButtons toButton + ("" "Plus infinity" plusInfinity) + ("" ( + (text "A finite point:\tab{15}") + (bcStrings (10 y to EM . bcOptional))) toPoint)) + (doneButton "Continue" bcDefiniteIntegrateGen)) + htShowPage() + +bcDefiniteIntegrateGen htPage == + integrand := htpLabelInputString(htPage,'integrand) + var := htpLabelInputString(htPage,'symbol) + lowerLimit := + htpButtonValue(htPage,'fromButton) = 'fromPoint => + htpLabelInputString(htPage,'from) + '"%minusInfinity" + upperLimit := + htpButtonValue(htPage,'toButton) = 'toPoint => + htpLabelInputString(htPage,'to) + '"%plusInfinity" + varpart := STRCONC(var,'" = ",lowerLimit,'"..",upperLimit) + bcGen + STRCONC('"integrate(",integrand,'",",varpart,'")") + +bcSum() == + htInitPage("Sum Basic Command",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain S (String)) + (isDomain SY (Symbol))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em function} you would like to sum:") + (text . "\newline\tab{2} ") + (bcStrings (44 "i**3" summand EM)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em summation index}:") + (text . "\tab{36}") + (bcStrings (10 i index SY)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the limits of the sum:") + (text . "\newline\tab{10}{\em From:}") + (bcStrings (10 1 first S)) + (text . "\tab{32}{\em To:}") + (text . "\tab{36}") + (bcStrings (10 n last S)) + (doneButton "Continue" bcSumGen)) + htShowPage() + +bcSumGen htPage == + mand := htpLabelInputString(htPage,'summand) + index := htpLabelInputString(htPage,'index) + first := htpLabelInputString(htPage,'first) + last := htpLabelInputString(htPage,'last) + bcGen STRCONC('"sum(",mand,'",",index,'" = ",first,'"..",last,'")") + +bcProduct() == + htInitPage("Product Basic Command",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain S (String)) + (isDomain SY (Symbol))) + (text . "Enter the {\em function} you would like to compute the product of:") + (inputStrings ("" "" 45 "i**2" mand EM)) + (text . "\vspace{1}\newline") + (inputStrings ("Enter the {\em index of the product}:" "" 5 i index SY)) + (text . "\vspace{1}\newline Enter the limits of the index:") + (inputStrings + ("\newline{\em From:}" "" 10 "1" first EM) + ("{\em To:}\space{2}" "" 10 "n" last EM)) + (doneButton "Continue" bcProductGen)) + htShowPage() + +bcProductGen htPage == + mand := htpLabelInputString(htPage,'mand) + index := htpLabelInputString(htPage,'index) + first := htpLabelInputString(htPage,'first) + last := htpLabelInputString(htPage,'last) + bcGen STRCONC('"product(",mand,'",",index,'",",first,'",",last,'")") + +bcDifferentiate() == + htInitPage("Differentiate Basic Command",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain S (String)) + (isDomain SY (Symbol))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em function} you want to differentiate:") + (text . "\newline\tab{2} ") + (bcStrings (55 "sin(x*y)" diffand EM)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "\newline List the {\em variables} you want to differentiate with respect to?") + (text . "\newline\tab{2} ") + (bcStrings (55 "x y" variables S . quoteString)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "\newline List the number of {\em times} you want to differentiate with respect to each variable (leave blank if once for each)") + (text . "\newline\tab{2} ") + (bcStrings (55 "1 2" times S . quoteString))) + htMakeDoneButton('"Continue", 'bcDifferentiateGen) + htShowPage() + +bcDifferentiateGen htPage == + mand := htpLabelInputString(htPage,'diffand) + varlist := bcString2WordList htpLabelInputString(htPage,'variables) + indexList := bcString2WordList htpLabelInputString(htPage,'times) + varpart := + #varlist > 1 => bcwords2liststring varlist + first varlist + indexpart := + null indexList => nil + null rest indexList => first indexList + #indexList = #varlist => bcwords2liststring indexList + bcError '"You must say how many times you want to differentiate with respect to each variable---or leave that entry blank" + lastPart := + indexpart => STRCONC('",",indexpart,'")") + '")" + bcGen STRCONC('"differentiate(",mand,'",",varpart,lastPart) + +bcDraw() == + htInitPage('"Draw Basic Command",nil) + bcHt '"What would you like to draw?" + bcHt '"\newline\centerline{{\em Two Dimensional Plots}}\newline" + bcHt '"\lispdownlink{A function of one variable}{(|bcDraw2Dfun|)}" + bcHt '"\space{2}y = f(x)\newline" + bcHt '"\lispdownlink{A parametrically defined curve}{(|bcDraw2Dpar|)}" + bcHt '"\space{2}(x(t), y(t))\newline" + bcHt '"\lispdownlink{A solution to a polynomial equation}{(|bcDraw2DSolve|)}" + bcHt '"\space{2} p(x,y) = 0\newline" + bcHt '"\vspace{1}\newline " + bcHt '"\centerline{{\em Three Dimensional Surfaces}}\newline\newline" + bcHt '"\lispdownlink{A function of two variables}{(|bcDraw3Dfun|)}" + bcHt '"\space{2} z = f(x,y)\newline" + bcHt '"\lispdownlink{A parametrically defined tube}{(|bcDraw3Dpar|)}" + bcHt '"\space{2}(x(t), y(t), z(t))\newline" + bcHt '"\lispdownlink{A parameterically defined surface}{(|bcDraw3Dpar1|)}" + bcHt '"\space{2}(x(u,v), y(u,v), z(u,v))\newline" + htShowPage() + + +bcDraw2Dfun() == + htInitPage('"Draw Basic Command",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float)) + (isDomain SY (Symbol))) + (text + "\centerline{Drawing {\em y = f(x)}}\newline " + "\centerline{where {\em y} is the dependent variable and}\newline " + "\centerline{where {\em x} is the independent variable}\vspace{1}\newline " + "\menuitemstyle{}\tab{2}What {\em function} f would you like to draw?\newline\tab{2}") + (bcStrings (55 "x*cos(x)" function EM)) + (text . "\vspace{1}\newline\menuitemstyle{}\tab{2}Enter {\em dependent} variable:") + (bcStrings (6 y dependent SY)) + (text . "\newline\vspace{1}\newline ") + (text . "\menuitemstyle{}\tab{2}Enter {\em independent} variable and {\em range}:\newline\tab{2} ") + (text . "{\em Variable:}") + (bcStrings (6 x ind SY)) + (text . "ranges {\em from:}") + (bcStrings (9 0 from1 F)) + (text . "{\em to:}") + (bcStrings (9 30 to1 F)) + (text + "\indent{0}\vspace{1}\newline\menuitemstyle{}\tab{2} " + "Optionally enter a {\em title} for your curve:" + ) + (bcStrings (15 "y = x*cos(x)" title S)) + (text . "\indent{0}") + (doneButton "Continue" bcDraw2DfunGen) + (text . "{}")) + htShowPage() + +bcDraw2DfunGen htPage == + fun := htpLabelInputString(htPage,'function) + dep := htpLabelInputString(htPage,'dependent) + ind := htpLabelInputString(htPage,'ind) + from1 := htpLabelInputString(htPage,'from1) + to1 := htpLabelInputString(htPage,'to1) + title := htpLabelInputString(htPage,'title) + if (title ^= '"") then + titlePart := STRCONC('"{}",'"title ==_"",title,'"_"") + bcFinish('"draw",fun,bcDrawIt2(ind,from1,to1),titlePart) + else + bcFinish('"draw",fun,bcDrawIt2(ind,from1,to1)) + + +bcDraw2Dpar() == + htInitPage('"Draw Basic Command",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float)) + (isDomain SY (Symbol))) + (text + "\centerline{Drawing a parametrically defined curve:}\newline " + "\centerline{{\em ( f1(t), f2(t) )}}\newline " + "\centerline{in terms of two functions {\em f1} and {\em f2}}" + "\centerline{and an independent variable {\em t}}\vspace{1}\newline" + "\menuitemstyle{}\tab{2}Enter the two {\em functions:}") + (text . "\newline\tab{2}{\em Function 1:}") + (bcStrings (44 "-9*sin(4*t/5)" function1 EM)) + (text . "\newline\tab{2}{\em Function 2:}") + (bcStrings (44 "8*sin(t)" function2 EM)) + (text ."\vspace{1}\newline\menuitemstyle{}\tab{2}Enter {\em independent} variable and range:\newline\tab{2} ") + (text . "{\em Variable:}") + (bcStrings (6 t ind SY)) + (text . "ranges {\em from:}") + (bcStrings (9 "-5*\%pi" from1 F)) + (text . "{\em to:}") + (bcStrings (9 "5*\%pi" to1 F)) + (text + "\vspace{1}\newline\menuitemstyle{}\tab{2}" + "Optionally enter a {\em title} for your curve:") + (bcStrings (15 "Lissajous" title S)) + (text . "\indent{0}") + (doneButton "Continue" bcDraw2DparGen)) + htShowPage() + +bcDraw2DparGen htPage == + fun1 := htpLabelInputString(htPage,'function1) + fun2 := htpLabelInputString(htPage,'function2) + ind := htpLabelInputString(htPage,'ind) + from1 := htpLabelInputString(htPage,'from1) + to1 := htpLabelInputString(htPage,'to1) + title := htpLabelInputString(htPage,'title) + curvePart := STRCONC('"curve(",'"{}",fun1,'",{}",fun2,'")") + if (title ^= '"") then + titlePart := (title = '"" => nil; STRCONC('"{}",'"title ==_"",title,'"_"")) + bcFinish('"draw",curvePart,bcDrawIt2(ind,from1,to1),titlePart) + else + bcFinish('"draw",curvePart,bcDrawIt2(ind,from1,to1)) + +bcDraw2DSolve() == + htInitPage('"Draw Basic Command",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float)) + (isDomain SY (Symbol))) + (text + "\centerline{Plotting the solution to {\em p(x,y) = 0}, where} " + "\centerline{{\em p} is a polynomial in two variables {\em x} and {\em y}}" + "\vspace{1}\newline\menuitemstyle{}\tab{2}Enter the {\em polynomial} p:" + "\newline\tab{2}") + (bcStrings (40 "y**2+7*x*y-(x**3+16*x)" function EM)) + (text . "\vspace{1}\newline\menuitemstyle{}\tab{2}Enter the {\em variables}:") + (text . "\newline\tab{2}{\em Variable 1:} ") + (bcStrings (4 x independent1 SY)) + (text . "ranges {\em from:}") + (bcStrings (9 -15 from1 F)) + (text . "{\em to:}") + (bcStrings (9 10 to1 F)) + (text . "\newline\tab{2}{\em Variable 2:} ") + (bcStrings (4 y independent2 SY)) + (text . "ranges {\em from:}") + (bcStrings (9 -10 from2 F)) + (text . "{\em to:}") + (bcStrings (9 50 to2 F)) + (text + "\indent{0}\vspace{1}\newline\menuitemstyle{}\tab{2} " + "Optionally enter a {\em title} for your curve:") + (bcStrings (15 "" title S)) + (text . "\indent{0}")) + htMakeDoneButton('"Continue",'bcDraw2DSolveGen) + htShowPage() + +bcDraw2DSolveGen htPage == + fun := htpLabelInputString(htPage,'function) + ind1 := htpLabelInputString(htPage,'independent1) + from1 := htpLabelInputString(htPage,'from1) + to1 := htpLabelInputString(htPage,'to1) + ind2 := htpLabelInputString(htPage,'independent2) + from2 := htpLabelInputString(htPage,'from2) + to2 := htpLabelInputString(htPage,'to2) + title := htpLabelInputString(htPage,'title) + clipPart := STRCONC('"{}",'"range==[{}",from1,'"..",to1,",{}",from2,'"..",to2,'"]") + if (title ^= '"") then + titlePart := (title = '"" => nil; STRCONC('"{}",'"title ==_"",title,'"_"")) + bcFinish('"draw",STRCONC(fun,'" = 0 "),ind1,ind2,clipPart,titlePart) + else + bcFinish('"draw",STRCONC(fun,'" = 0 "),ind1,ind2,clipPart) + +bcDraw3Dfun() == + htInitPage('"Three Dimensional Draw Basic Command",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float)) + (isDomain SY (Symbol))) + (text + "\centerline{Drawing {\em z = f(x,y)}}\newline " + "\centerline{where {\em z} is the dependent variable and}\newline " + "\centerline{where {\em x, y} are the independent variables}\vspace{1}\newline\menuitemstyle{}\tab{2} " + "What {\em function} f which you like to draw?\newline\tab{2}") + (bcStrings (55 "exp(cos(x-y)-sin(x*y))-2" function EM)) + (text . "\newline\menuitemstyle{}\tab{2}Enter {\em dependent} variable:") + (bcStrings (6 z dependent SY)) + (text + "\vspace{1}\newline\menuitemstyle{}\tab{2}" + "Enter {\em independent} variables and ranges:\newline\tab{2} " + "{\em Variable:}") + (bcStrings (6 x independent1 SY)) + (text . "ranges {\em from:}") + (bcStrings (9 -5 from1 F)) + (text . "{\em to:}") + (bcStrings (9 5 to1 F)) + (text . "\newline\tab{2}{\em Variable:}") + (bcStrings (6 y independent2 SY)) + (text . "ranges {\em from:}") + (bcStrings (9 -5 from2 F)) + (text . "{\em to:}") + (bcStrings (9 5 to2 F)) + (text + "\indent{0}\vspace{1}\newline\menuitemstyle{}\tab{2} " + "Optionally enter a {\em title} for your surface:") + (bcStrings (15 "" title S)) + (text . "\indent{0}") + (doneButton "Continue" bcDraw3DfunGen)) + htShowPage() + +bcDraw3DfunGen htPage == + fun := htpLabelInputString(htPage,'function) + dep := htpLabelInputString(htPage,'dependent) + ind1 := htpLabelInputString(htPage,'independent1) + from1 := htpLabelInputString(htPage,'from1) + to1 := htpLabelInputString(htPage,'to1) + ind2 := htpLabelInputString(htPage,'independent2) + from2 := htpLabelInputString(htPage,'from2) + to2 := htpLabelInputString(htPage,'to2) + title := htpLabelInputString(htPage,'title) + if (title ^= '"") then + titlePart := (title = '"" => nil;STRCONC('"{}",'"title ==_"",title,'"_"")) + bcFinish('"draw",fun,bcDrawIt2(ind1,from1,to1),bcDrawIt2(ind2,from2,to2),titlePart) + else + bcFinish('"draw",fun,bcDrawIt2(ind1,from1,to1),bcDrawIt2(ind2,from2,to2)) + +bcDraw3Dpar() == + htInitPage('"Draw Basic Command",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float)) + (isDomain SY (Symbol))) + (text + "\centerline{Drawing a parametrically defined curve:" + "{\em ( f1(t), f2(t), f3(t) )}}\newline " + "\centerline{in terms of three functions {\em f1}, {\em f2}, and {\em f3}}\newline " + "\centerline{and an independent variable {\em t}}\vspace{1}\newline\menuitemstyle{}\tab{2} " + "Enter the three {\em functions} of the independent variable:") + (text . "\newline\tab{2}{\em Function f1:}") + (bcStrings (42 "1.3*cos(2*t)*cos(4*t) + sin(4*t)*cos(t)" function1 EM)) + (text . "\newline\tab{2}{\em Function f2:}") + (bcStrings (42 "1.3*sin(2*t)*cos(4*t) - sin(4*t)*sin(t)" function2 EM)) + (text . "\newline\tab{2}{\em Function f3:}") + (bcStrings (42 "2.5*cos(4*t)" function3 EM)) + (text ."\vspace{1}\newline\menuitemstyle{}\tab{2}Enter {\em independent} variable and range:\newline\tab{2} ") + (text ."{\em Variable:}") + (bcStrings (6 t ind SY)) + (text . "ranges {\em from:}") + (bcStrings (9 0 from1 F)) + (text "{\em to:}") + (bcStrings (9 "4*\%pi" to1 F)) + (text + "\indent{0}\vspace{1}\newline\menuitemstyle{}\tab{2} " + "Optionally enter a {\em title} for your surface:") + (bcStrings (15 "knot" title S)) + (text . "\indent{0}") + (doneButton "Continue" bcDraw3DparGen)) + htShowPage() + +bcDraw3DparGen htPage == + fun1 := htpLabelInputString(htPage,'function1) + fun2 := htpLabelInputString(htPage,'function2) + fun3 := htpLabelInputString(htPage,'function3) + ind := htpLabelInputString(htPage,'ind) + from1 := htpLabelInputString(htPage,'from1) + to1 := htpLabelInputString(htPage,'to1) + title := htpLabelInputString(htPage,'title) + curvePart := STRCONC('"curve(",'"{}",fun1,'",{}",fun2,'",{}",fun3,'")") + tubePart := '"{}tubeRadius==.25,{}tubePoints==16" + if (title ^= '"") then + titlePart := (title = '"" => nil; STRCONC('"{}",'"title ==_"",title,'"_"")) + bcFinish('"draw",curvePart,bcDrawIt2(ind,from1,to1),tubePart,titlePart) + else + bcFinish('"draw",curvePart,bcDrawIt2(ind,from1,to1),tubePart) + +bcDraw3Dpar1() == + htInitPage('"Draw Basic Command",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float)) + (isDomain SY (Symbol))) + (text + "\centerline{Drawing a parametrically defined surface:}\newline " + "\centerline{{\em ( f1(u,v), f2(u,v), f3(u,v) )}}\newline " + "\centerline{in terms of three functions {\em f1}, {\em f2}, and {\em f3}}\newline " + "\centerline{and two independent variables {\em u} and {\em v}}\vspace{1}\newline\menuitemstyle{}\tab{2}" + "Enter the three {\em functions} of the independent variables:") + (text . "\newline\tab{2}") + (text . "{\em Function f1:}") + (bcStrings (43 "u*sin(v)" function1 EM)) + (text . "\newline\tab{2}") + (text . "{\em Function f2:}") + (bcStrings (43 "v*cos(u)" function2 EM)) + (text . "\newline\tab{2}") + (text . "{\em Function f3:}") + (bcStrings (43 "u*cos(v)" function3 EM)) + (text . "\newline\menuitemstyle{}\tab{2}Enter independent {\em variables} and ranges:") + (text . "\newline\tab{2}") + (text . "{\em Variable 1:}") + (bcStrings (5 u ind1 SY)) + (text . "ranges {\em from:}") + (bcStrings (9 "-\%pi" from1 F)) + (text . "{\em to:}") + (bcStrings (9 "\%pi" to1 F)) + (text . "\newline\tab{2}") + (text . "{\em Variable 2:}") + (bcStrings (5 v ind2 SY)) + (text . "ranges {\em from:}") + (bcStrings (9 "-\%pi/2" from2 F)) + (text . "{\em to:}") + (bcStrings (9 "\%pi/2" to2 F)) + (text + "\indent{0}\newline\menuitemstyle{}\tab{2} " + "Optionally enter a {\em title} for your surface:") + (bcStrings (15 "surface" title S)) + (text . "\indent{0}")) + htMakeDoneButton ('"Continue",'bcDraw3Dpar1Gen) + htShowPage() + +bcDraw3Dpar1Gen htPage == + fun1 := htpLabelInputString(htPage,'function1) + fun2 := htpLabelInputString(htPage,'function2) + fun3 := htpLabelInputString(htPage,'function3) + ind1 := htpLabelInputString(htPage,'ind1) + from1 := htpLabelInputString(htPage,'from1) + to1 := htpLabelInputString(htPage,'to1) + ind2 := htpLabelInputString(htPage,'ind2) + from2 := htpLabelInputString(htPage,'from2) + to2 := htpLabelInputString(htPage,'to2) + title := htpLabelInputString(htPage,'title) + r1 := bcDrawIt2(ind1,from1,to1) + r2 := bcDrawIt2(ind2,from2,to2) + surfacePart := STRCONC('"surface(",'"{}",fun1,'",{}",fun2,'",{}",fun3,'")") + if (title ^= '"") then + titlePart := (title = '"" => nil; STRCONC('"{}",'"title ==_"",title,'"_"")) + bcFinish('"draw",surfacePart,r1,r2,titlePart) + else + bcFinish('"draw",surfacePart,r1,r2) + +bcSeries() == + htInitPage('"Series Basic Command",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain S (String)) + (isDomain SY (Symbol))) + (text . "Create a series by: ") + (text . "\beginmenu") + (text . "\item ") + (bcLinks ("\menuitemstyle{Expansion}" "" bcSeriesExpansion NILl)) + (text . "\tab{11}Expand a function in a series around a point") + (text . "\item ") + (bcLinks ("\menuitemstyle{Formula}" "" bcSeriesByFormula NIL)) + (text . "\tab{11}Give a formula for the {\em i}'th coefficient") + (text . "\endmenu")) + htShowPage() + +bcSeriesExpansion(a,b) == + htInitPage('"Series Expansion Basic Command",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain EEM (Expression $EmptyMode)) + (isDomain S (String)) + (isDomain SY (Symbol))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em function} you want to expand in a power series") + (text . "\newline\tab{2} ") + (bcStrings (55 "log(cot(x))" function EM)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em power series variable}") + (text . "\tab{49}") + (bcStrings (8 x variable SY)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em point} about which you want to expand") + (text . "\tab{49}") + (bcStrings (8 "\%pi/2" point EM))) + htMakeDoneButton('"Continue",'bcSeriesExpansionGen) + htShowPage() + +bcSeriesExpansionGen htPage == + fun := htpLabelInputString(htPage,'function) + var := htpLabelInputString(htPage,'variable) + point := htpLabelInputString(htPage,'point) + terms := htpLabelInputString(htPage,'numberOfTerms) + bcFinish("series",fun,STRCONC(var,'" = ",point)) + +bcSeriesByFormula(a,b) == + htInitPage('"Power Series Basic Command",nil) + htMakePage '( + (text . "Select the kind of power series you want to create:") + (text . "\beginmenu") + (text . "\item ") + (bcLinks ("\menuitemstyle{Taylor Series}" "" bcTaylorSeries taylor)) + (text . "\newline Series where the exponent ranges over the integers from a {\em non-negative integer} value to plus infinity by an arbitrary {\em positive integer} step size") + (text . "\item ") + (bcLinks ("\menuitemstyle{Laurent Series}" "" bcLaurentSeries laurent)) + (text . "\newline Series where the exponent ranges from an arbitrary {\em integer} value to plus infinity by an arbitrary {\em positive integer} step size") + (text . "\item ") + (bcLinks ("\menuitemstyle{Puiseux Series}" "" bcPuiseuxSeries puiseux)) + (text . "\newline Series where the exponent ranges from an arbitrary {\em rational value} to plus infinity by an arbitrary {\em positive rational number} step size") + (text . "\endmenu")) + htShowPage() + +bcTaylorSeries(a,b) == + htInitPage('"Taylor Series Basic Command",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain EEM (Expression $EmptyMode)) + (isDomain S (String)) + (isDomain SY (Symbol))) + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the formula for the general coefficient of the series") + (text . "\newline\tab{2} ") + (bcStrings (55 "1/factorial(i)" formula EM)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em index variable} for your formula") + (text . "\tab{49}") + (bcStrings (8 i index SY)) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em power series variable}") + (text . "\tab{49}") + (bcStrings (8 x variable SY)) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em point} about which you want to expand") + (text . "\tab{49}") + (bcStrings (8 0 point EM)) + (text . "\blankline ") + (text ."For Taylor Series, the exponent of the power series variable ranges from an {\em initial value}, an arbitrary non-negative integer, to plus infinity; the {\em step size} is any positive integer.") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em initial value} of the index (an integer)") + (text . "\tab{49}") + (bcStrings (8 "0" min I)) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em step size} (a positive integer)") + (text . "\tab{49}") + (bcStrings (8 "1" step PI)) + (doneButton "Continue" bcTaylorSeriesGen)) + htShowPage() + +bcSeriesByFormulaGen htPage == bcNotReady() + +bcLaurentSeries(a,b) == + htInitPage('"Laurent Series Basic Command",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain EEM (Expression $EmptyMode)) + (isDomain S (String)) + (isDomain I (Integer)) + (isDomain PI (PositiveInteger)) + (isDomain SY (Symbol))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the formula for the general coefficient of the series") + (text . "\newline\tab{2} ") + (bcStrings (55 "(-1)**(n - 1)/(n + 2)" formula EM)) + (text . "\vspace{1}\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em index variable} for your formula") + (text . "\tab{49}") + (bcStrings (8 n index SY)) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em power series variable}") + (text . "\tab{49}") + (bcStrings (8 x variable SY)) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em point} about which you want to expand") + (text . "\tab{49}") + (bcStrings (8 0 point F)) + (text . "\blankline") + (text . "\newline For Laurent Series, the exponent of the power series variable ranges from an {\em initial value}, an arbitrary integer value, to plus infinity; the {\em step size} is any positive integer.") + (text . "\blankline") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em initial value} of the index (an integer)") + (text . "\tab{49}") + (bcStrings (8 "-1" min I)) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em step size} (a positive integer)") + (text . "\tab{49}") + (bcStrings (8 "1" step PI)) + (doneButton "Continue" bcLaurentSeriesGen)) + htShowPage() + +bcPuiseuxSeries(a,b) == + htInitPage('"Puiseux Series Basic Command",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain EEM (Expression $EmptyMode)) + (isDomain S (String)) + (isDomain I (Integer)) + (isDomain PI (PositiveInteger)) + (isDOmain RN (Fraction (Integer))) + (isDomain SY (Symbol))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text ."Enter the {\em formula} for the general coefficient of the series") + (text . "\newline\tab{2} ") + (bcStrings(55 "(-1)**((3*n - 4)/6)/factorial(n - 1/3)" formula EM)) + (text . "\vspace{1}\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em index variable} for your formula") + (text . "\tab{49}") + (bcStrings (8 n index SY)) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em power series variable}") + (text . "\tab{49}") + (bcStrings (8 x variable SY)) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em point} about which you want to expand") + (text . "\tab{49}") + (bcStrings (8 0 point F)) + (text . "\blankline ") + (text . "For Puiseux Series, the exponent of the power series variable ranges from an {\em initial value}, an arbitary rational number, to plus infinity; the {\em step size} is an any positive rational number.") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em initial value} of index (a rational number)") + (text . "\tab{51}") + (bcStrings (6 "4/3" min RN)) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em step size} (a positive rational number)") + (text . "\tab{51}") + (bcStrings (6 "2" step RN)) + (doneButton "Continue" bcPuiseuxSeriesGen)) + htShowPage() + +bcTaylorSeriesGen htPage == bcSeriesGen(htPage) + +bcLaurentSeriesGen htPage == + bcSeriesGen(htPage) + +bcPuiseuxSeriesGen htPage == + bcSeriesGen(htPage) + +bcSeriesGen(htPage) == + step:= htpLabelInputString(htPage,'step) + min := htpLabelInputString(htPage,'min) + formula := htpLabelInputString(htPage,'formula) + index := htpLabelInputString(htPage,'index) + var := htpLabelInputString(htPage,'variable) + point := htpLabelInputString(htPage,'point) + varPart := STRCONC(var,'" = ",point) + minPart := STRCONC(min,'"..") + bcFinish('"series",STRCONC(index,'" +-> ",formula),varPart,minPart,step) + +bcLimit() == + htInitPage('"Limit Basic Command",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain S (String)) + (isDomain SY (Symbol))) + (text . "What kind of limit do you want to compute? ") + (text . "\blankline ") + (text . "\beginmenu") + (text . "\item ") + (bcLinks ("\menuitemstyle{A real limit?}" "" bcRealLimit real)) + (text . "\indentrel{17}\tab{0}") + (text . "The limit as the variable approaches a {\em real} value along the real axis") + (text . "\indentrel{-17}") + (text . "\item ") + (text . "\blankline ") + (bcLinks ("\menuitemstyle{A complex limit?}" "" bcComplexLimit complex)) + (text . "\indentrel{17}\tab{0}") + (text . "The limit as the variable approaches a {\em complex} value along any path in the complex plane") + (text . "\indentrel{-17}") + (text . "\endmenu") + ) + htShowPage() + +bcRealLimit(a,b) == + htInitPage('"Real Limit Basic Command",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain SY (Symbol))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em function} you want to compute the limit of:") + (text . "\newline\tab{2} ") + (bcStrings (45 "x*sin(1/x)" expression EM)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the name of the {\em variable}: ") + (text . "\tab{41}") + (bcStrings (6 x variable SY)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Compute the limit at") + (radioButtons location + ("A finite point:" ( + (text . "\tab{33}") + (bcStrings (6 0 point F))) finitePoint) + ("Plus infinity" "" plusInfinity) + ("Minus infinity" "" minusInfinity)) + (doneButton "Continue" bcRealLimitGen)) + htShowPage() + +bcRealLimitGen htPage == + (p := htpButtonValue(htPage,'location)) ^= 'finitePoint => + fun := htpLabelInputString(htPage,'expression) + var := htpLabelInputString(htPage,'variable) + loc := + p = 'plusInfinity => '"%plusInfinity" + '"%minusInfinity" + bcFinish('"limit",fun,STRCONC(var,'" = ",loc)) + page := htInitPage('"Real Limit Basic Command",nil) + htMakePage '( + (text . "Compute the limit") + (lispLinks + ("\menuitemstyle{From both directions}" "" bcRealLimitGen1 both) + ("\menuitemstyle{From the right}" "" bcRealLimitGen1 right) + ("\menuitemstyle{From the left}" "" bcRealLimitGen1 left))) + htpSetProperty(page,'fun,htpLabelInputString(htPage,'expression)) + htpSetProperty(page,'var,htpLabelInputString(htPage,'variable)) + htpSetProperty(page,'loc,htpLabelInputString(htPage,'point)) + htShowPage() + +bcRealLimitGen1(htPage,key) == + direction := + key = 'right => '"_"right_"" + key = 'left => '"_"left_"" + nil + fun := htpProperty(htPage,'fun) + var := htpProperty(htPage,'var) + loc := htpProperty(htPage,'loc) + varPart := STRCONC(var,'" = ",loc) + bcFinish('"limit",fun,varPart,direction) + +bcComplexLimit(a,b) == + htInitPage('"Complex Limit Basic Command",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain SY (Symbol))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em function} you want to compute the limit of:") + (text . "\newline\tab{2} ") + (bcStrings (40 "sin(a*x)/tan(b*x)" expression EM)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the name of the {\em variable}: ") + (text . "\tab{37}") + (bcStrings (5 x variable SY)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Compute the limit at") + (radioButtons location + ("A finite point:" ( + (text . "\newline\space{0}Real part:\space{3}") + (bcStrings (20 0 real F)) + (text . "\newline Complex part:") + (bcStrings (20 0 complex F))) finitePoint) + ("Complex infinity" "" complexInfinity)) + (doneButton "Continue" bcComplexLimitGen)) + htShowPage() + +bcComplexLimitGen htPage == + fun := htpLabelInputString(htPage,'expression) + var := htpLabelInputString(htPage,'variable) + loc := + (p := htpButtonValue(htPage,'location)) = 'finitePoint => + real := htpLabelInputString(htPage,'real) + comp := htpLabelInputString(htPage,'complex) + complexPart := + comp = '"0" => '"" + comp = '"1" => '"%i" + STRCONC(comp,'"*%i") + real = '"0" => + complexPart = '"" => "0" + complexPart + complexPart = '"" => real + STRCONC(real,'" + ",complexPart) + '"%infinity" + varPart := STRCONC(var,'" = ",loc) + bcFinish('"complexLimit",fun,varPart) + + diff --git a/src/interp/bc-misc.boot.pamphlet b/src/interp/bc-misc.boot.pamphlet deleted file mode 100644 index 776273a1..00000000 --- a/src/interp/bc-misc.boot.pamphlet +++ /dev/null @@ -1,949 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp bc-misc.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\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. - -@ -<<*>>= -<> - -import '"bc-util" -)package "BOOT" - ---Hypertex commands other than solve and matrix - -bcDrawIt2(ind,a,b) == STRCONC('"{}",ind,'"=",a,'"{}..",b,'"{}") - -bcIndefiniteIntegrate() == - htInitPage("Indefinite Integration Basic Command",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain S (String)) - (isDomain SY (Symbol))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em function} you would like to integrate:") - (text . "\newline\tab{2} ") - (bcStrings (45 "1/(x**2 + 6)" integrand EM)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em variable of integration}:") - (text . "\tab{37}") - (bcStrings (10 x symbol SY)) - (doneButton "Continue" bcIndefiniteIntegrateGen)) - htShowPage() - -bcIndefiniteIntegrateGen htPage == - integrand := htpLabelInputString(htPage,'integrand) - var := htpLabelInputString(htPage,'symbol) - bcGen STRCONC('"integrate(",integrand,'",",var,")") - - -bcDefiniteIntegrate() == - htInitPage("Definite Integration Basic Command",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain S (String)) - (isDomain SY (Symbol))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em function} you would like to integrate:") - (text . "\newline\tab{2} ") - (bcStrings (45 "1/(x**2 + 6)" integrand EM)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em variable of integration}:") - (text . "\tab{37}") - (bcStrings (10 x symbol SY)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "\newline Enter {\em lower limit}:") - (radioButtons fromButton - ("" "Minus infinity" minusInfinity) - ("" ( - (text . "A finite point:\tab{15}") - (bcStrings (10 0 from EM . bcOptional))) fromPoint)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "\indent{2}\newline Enter {\em upper limit}:") - (radioButtons toButton - ("" "Plus infinity" plusInfinity) - ("" ( - (text "A finite point:\tab{15}") - (bcStrings (10 y to EM . bcOptional))) toPoint)) - (doneButton "Continue" bcDefiniteIntegrateGen)) - htShowPage() - -bcDefiniteIntegrateGen htPage == - integrand := htpLabelInputString(htPage,'integrand) - var := htpLabelInputString(htPage,'symbol) - lowerLimit := - htpButtonValue(htPage,'fromButton) = 'fromPoint => - htpLabelInputString(htPage,'from) - '"%minusInfinity" - upperLimit := - htpButtonValue(htPage,'toButton) = 'toPoint => - htpLabelInputString(htPage,'to) - '"%plusInfinity" - varpart := STRCONC(var,'" = ",lowerLimit,'"..",upperLimit) - bcGen - STRCONC('"integrate(",integrand,'",",varpart,'")") - -bcSum() == - htInitPage("Sum Basic Command",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain S (String)) - (isDomain SY (Symbol))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em function} you would like to sum:") - (text . "\newline\tab{2} ") - (bcStrings (44 "i**3" summand EM)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em summation index}:") - (text . "\tab{36}") - (bcStrings (10 i index SY)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the limits of the sum:") - (text . "\newline\tab{10}{\em From:}") - (bcStrings (10 1 first S)) - (text . "\tab{32}{\em To:}") - (text . "\tab{36}") - (bcStrings (10 n last S)) - (doneButton "Continue" bcSumGen)) - htShowPage() - -bcSumGen htPage == - mand := htpLabelInputString(htPage,'summand) - index := htpLabelInputString(htPage,'index) - first := htpLabelInputString(htPage,'first) - last := htpLabelInputString(htPage,'last) - bcGen STRCONC('"sum(",mand,'",",index,'" = ",first,'"..",last,'")") - -bcProduct() == - htInitPage("Product Basic Command",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain S (String)) - (isDomain SY (Symbol))) - (text . "Enter the {\em function} you would like to compute the product of:") - (inputStrings ("" "" 45 "i**2" mand EM)) - (text . "\vspace{1}\newline") - (inputStrings ("Enter the {\em index of the product}:" "" 5 i index SY)) - (text . "\vspace{1}\newline Enter the limits of the index:") - (inputStrings - ("\newline{\em From:}" "" 10 "1" first EM) - ("{\em To:}\space{2}" "" 10 "n" last EM)) - (doneButton "Continue" bcProductGen)) - htShowPage() - -bcProductGen htPage == - mand := htpLabelInputString(htPage,'mand) - index := htpLabelInputString(htPage,'index) - first := htpLabelInputString(htPage,'first) - last := htpLabelInputString(htPage,'last) - bcGen STRCONC('"product(",mand,'",",index,'",",first,'",",last,'")") - -bcDifferentiate() == - htInitPage("Differentiate Basic Command",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain S (String)) - (isDomain SY (Symbol))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em function} you want to differentiate:") - (text . "\newline\tab{2} ") - (bcStrings (55 "sin(x*y)" diffand EM)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "\newline List the {\em variables} you want to differentiate with respect to?") - (text . "\newline\tab{2} ") - (bcStrings (55 "x y" variables S . quoteString)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "\newline List the number of {\em times} you want to differentiate with respect to each variable (leave blank if once for each)") - (text . "\newline\tab{2} ") - (bcStrings (55 "1 2" times S . quoteString))) - htMakeDoneButton('"Continue", 'bcDifferentiateGen) - htShowPage() - -bcDifferentiateGen htPage == - mand := htpLabelInputString(htPage,'diffand) - varlist := bcString2WordList htpLabelInputString(htPage,'variables) - indexList := bcString2WordList htpLabelInputString(htPage,'times) - varpart := - #varlist > 1 => bcwords2liststring varlist - first varlist - indexpart := - null indexList => nil - null rest indexList => first indexList - #indexList = #varlist => bcwords2liststring indexList - bcError '"You must say how many times you want to differentiate with respect to each variable---or leave that entry blank" - lastPart := - indexpart => STRCONC('",",indexpart,'")") - '")" - bcGen STRCONC('"differentiate(",mand,'",",varpart,lastPart) - -bcDraw() == - htInitPage('"Draw Basic Command",nil) - bcHt '"What would you like to draw?" - bcHt '"\newline\centerline{{\em Two Dimensional Plots}}\newline" - bcHt '"\lispdownlink{A function of one variable}{(|bcDraw2Dfun|)}" - bcHt '"\space{2}y = f(x)\newline" - bcHt '"\lispdownlink{A parametrically defined curve}{(|bcDraw2Dpar|)}" - bcHt '"\space{2}(x(t), y(t))\newline" - bcHt '"\lispdownlink{A solution to a polynomial equation}{(|bcDraw2DSolve|)}" - bcHt '"\space{2} p(x,y) = 0\newline" - bcHt '"\vspace{1}\newline " - bcHt '"\centerline{{\em Three Dimensional Surfaces}}\newline\newline" - bcHt '"\lispdownlink{A function of two variables}{(|bcDraw3Dfun|)}" - bcHt '"\space{2} z = f(x,y)\newline" - bcHt '"\lispdownlink{A parametrically defined tube}{(|bcDraw3Dpar|)}" - bcHt '"\space{2}(x(t), y(t), z(t))\newline" - bcHt '"\lispdownlink{A parameterically defined surface}{(|bcDraw3Dpar1|)}" - bcHt '"\space{2}(x(u,v), y(u,v), z(u,v))\newline" - htShowPage() - - -bcDraw2Dfun() == - htInitPage('"Draw Basic Command",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float)) - (isDomain SY (Symbol))) - (text - "\centerline{Drawing {\em y = f(x)}}\newline " - "\centerline{where {\em y} is the dependent variable and}\newline " - "\centerline{where {\em x} is the independent variable}\vspace{1}\newline " - "\menuitemstyle{}\tab{2}What {\em function} f would you like to draw?\newline\tab{2}") - (bcStrings (55 "x*cos(x)" function EM)) - (text . "\vspace{1}\newline\menuitemstyle{}\tab{2}Enter {\em dependent} variable:") - (bcStrings (6 y dependent SY)) - (text . "\newline\vspace{1}\newline ") - (text . "\menuitemstyle{}\tab{2}Enter {\em independent} variable and {\em range}:\newline\tab{2} ") - (text . "{\em Variable:}") - (bcStrings (6 x ind SY)) - (text . "ranges {\em from:}") - (bcStrings (9 0 from1 F)) - (text . "{\em to:}") - (bcStrings (9 30 to1 F)) - (text - "\indent{0}\vspace{1}\newline\menuitemstyle{}\tab{2} " - "Optionally enter a {\em title} for your curve:" - ) - (bcStrings (15 "y = x*cos(x)" title S)) - (text . "\indent{0}") - (doneButton "Continue" bcDraw2DfunGen) - (text . "{}")) - htShowPage() - -bcDraw2DfunGen htPage == - fun := htpLabelInputString(htPage,'function) - dep := htpLabelInputString(htPage,'dependent) - ind := htpLabelInputString(htPage,'ind) - from1 := htpLabelInputString(htPage,'from1) - to1 := htpLabelInputString(htPage,'to1) - title := htpLabelInputString(htPage,'title) - if (title ^= '"") then - titlePart := STRCONC('"{}",'"title ==_"",title,'"_"") - bcFinish('"draw",fun,bcDrawIt2(ind,from1,to1),titlePart) - else - bcFinish('"draw",fun,bcDrawIt2(ind,from1,to1)) - - -bcDraw2Dpar() == - htInitPage('"Draw Basic Command",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float)) - (isDomain SY (Symbol))) - (text - "\centerline{Drawing a parametrically defined curve:}\newline " - "\centerline{{\em ( f1(t), f2(t) )}}\newline " - "\centerline{in terms of two functions {\em f1} and {\em f2}}" - "\centerline{and an independent variable {\em t}}\vspace{1}\newline" - "\menuitemstyle{}\tab{2}Enter the two {\em functions:}") - (text . "\newline\tab{2}{\em Function 1:}") - (bcStrings (44 "-9*sin(4*t/5)" function1 EM)) - (text . "\newline\tab{2}{\em Function 2:}") - (bcStrings (44 "8*sin(t)" function2 EM)) - (text ."\vspace{1}\newline\menuitemstyle{}\tab{2}Enter {\em independent} variable and range:\newline\tab{2} ") - (text . "{\em Variable:}") - (bcStrings (6 t ind SY)) - (text . "ranges {\em from:}") - (bcStrings (9 "-5*\%pi" from1 F)) - (text . "{\em to:}") - (bcStrings (9 "5*\%pi" to1 F)) - (text - "\vspace{1}\newline\menuitemstyle{}\tab{2}" - "Optionally enter a {\em title} for your curve:") - (bcStrings (15 "Lissajous" title S)) - (text . "\indent{0}") - (doneButton "Continue" bcDraw2DparGen)) - htShowPage() - -bcDraw2DparGen htPage == - fun1 := htpLabelInputString(htPage,'function1) - fun2 := htpLabelInputString(htPage,'function2) - ind := htpLabelInputString(htPage,'ind) - from1 := htpLabelInputString(htPage,'from1) - to1 := htpLabelInputString(htPage,'to1) - title := htpLabelInputString(htPage,'title) - curvePart := STRCONC('"curve(",'"{}",fun1,'",{}",fun2,'")") - if (title ^= '"") then - titlePart := (title = '"" => nil; STRCONC('"{}",'"title ==_"",title,'"_"")) - bcFinish('"draw",curvePart,bcDrawIt2(ind,from1,to1),titlePart) - else - bcFinish('"draw",curvePart,bcDrawIt2(ind,from1,to1)) - -bcDraw2DSolve() == - htInitPage('"Draw Basic Command",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float)) - (isDomain SY (Symbol))) - (text - "\centerline{Plotting the solution to {\em p(x,y) = 0}, where} " - "\centerline{{\em p} is a polynomial in two variables {\em x} and {\em y}}" - "\vspace{1}\newline\menuitemstyle{}\tab{2}Enter the {\em polynomial} p:" - "\newline\tab{2}") - (bcStrings (40 "y**2+7*x*y-(x**3+16*x)" function EM)) - (text . "\vspace{1}\newline\menuitemstyle{}\tab{2}Enter the {\em variables}:") - (text . "\newline\tab{2}{\em Variable 1:} ") - (bcStrings (4 x independent1 SY)) - (text . "ranges {\em from:}") - (bcStrings (9 -15 from1 F)) - (text . "{\em to:}") - (bcStrings (9 10 to1 F)) - (text . "\newline\tab{2}{\em Variable 2:} ") - (bcStrings (4 y independent2 SY)) - (text . "ranges {\em from:}") - (bcStrings (9 -10 from2 F)) - (text . "{\em to:}") - (bcStrings (9 50 to2 F)) - (text - "\indent{0}\vspace{1}\newline\menuitemstyle{}\tab{2} " - "Optionally enter a {\em title} for your curve:") - (bcStrings (15 "" title S)) - (text . "\indent{0}")) - htMakeDoneButton('"Continue",'bcDraw2DSolveGen) - htShowPage() - -bcDraw2DSolveGen htPage == - fun := htpLabelInputString(htPage,'function) - ind1 := htpLabelInputString(htPage,'independent1) - from1 := htpLabelInputString(htPage,'from1) - to1 := htpLabelInputString(htPage,'to1) - ind2 := htpLabelInputString(htPage,'independent2) - from2 := htpLabelInputString(htPage,'from2) - to2 := htpLabelInputString(htPage,'to2) - title := htpLabelInputString(htPage,'title) - clipPart := STRCONC('"{}",'"range==[{}",from1,'"..",to1,",{}",from2,'"..",to2,'"]") - if (title ^= '"") then - titlePart := (title = '"" => nil; STRCONC('"{}",'"title ==_"",title,'"_"")) - bcFinish('"draw",STRCONC(fun,'" = 0 "),ind1,ind2,clipPart,titlePart) - else - bcFinish('"draw",STRCONC(fun,'" = 0 "),ind1,ind2,clipPart) - -bcDraw3Dfun() == - htInitPage('"Three Dimensional Draw Basic Command",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float)) - (isDomain SY (Symbol))) - (text - "\centerline{Drawing {\em z = f(x,y)}}\newline " - "\centerline{where {\em z} is the dependent variable and}\newline " - "\centerline{where {\em x, y} are the independent variables}\vspace{1}\newline\menuitemstyle{}\tab{2} " - "What {\em function} f which you like to draw?\newline\tab{2}") - (bcStrings (55 "exp(cos(x-y)-sin(x*y))-2" function EM)) - (text . "\newline\menuitemstyle{}\tab{2}Enter {\em dependent} variable:") - (bcStrings (6 z dependent SY)) - (text - "\vspace{1}\newline\menuitemstyle{}\tab{2}" - "Enter {\em independent} variables and ranges:\newline\tab{2} " - "{\em Variable:}") - (bcStrings (6 x independent1 SY)) - (text . "ranges {\em from:}") - (bcStrings (9 -5 from1 F)) - (text . "{\em to:}") - (bcStrings (9 5 to1 F)) - (text . "\newline\tab{2}{\em Variable:}") - (bcStrings (6 y independent2 SY)) - (text . "ranges {\em from:}") - (bcStrings (9 -5 from2 F)) - (text . "{\em to:}") - (bcStrings (9 5 to2 F)) - (text - "\indent{0}\vspace{1}\newline\menuitemstyle{}\tab{2} " - "Optionally enter a {\em title} for your surface:") - (bcStrings (15 "" title S)) - (text . "\indent{0}") - (doneButton "Continue" bcDraw3DfunGen)) - htShowPage() - -bcDraw3DfunGen htPage == - fun := htpLabelInputString(htPage,'function) - dep := htpLabelInputString(htPage,'dependent) - ind1 := htpLabelInputString(htPage,'independent1) - from1 := htpLabelInputString(htPage,'from1) - to1 := htpLabelInputString(htPage,'to1) - ind2 := htpLabelInputString(htPage,'independent2) - from2 := htpLabelInputString(htPage,'from2) - to2 := htpLabelInputString(htPage,'to2) - title := htpLabelInputString(htPage,'title) - if (title ^= '"") then - titlePart := (title = '"" => nil;STRCONC('"{}",'"title ==_"",title,'"_"")) - bcFinish('"draw",fun,bcDrawIt2(ind1,from1,to1),bcDrawIt2(ind2,from2,to2),titlePart) - else - bcFinish('"draw",fun,bcDrawIt2(ind1,from1,to1),bcDrawIt2(ind2,from2,to2)) - -bcDraw3Dpar() == - htInitPage('"Draw Basic Command",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float)) - (isDomain SY (Symbol))) - (text - "\centerline{Drawing a parametrically defined curve:" - "{\em ( f1(t), f2(t), f3(t) )}}\newline " - "\centerline{in terms of three functions {\em f1}, {\em f2}, and {\em f3}}\newline " - "\centerline{and an independent variable {\em t}}\vspace{1}\newline\menuitemstyle{}\tab{2} " - "Enter the three {\em functions} of the independent variable:") - (text . "\newline\tab{2}{\em Function f1:}") - (bcStrings (42 "1.3*cos(2*t)*cos(4*t) + sin(4*t)*cos(t)" function1 EM)) - (text . "\newline\tab{2}{\em Function f2:}") - (bcStrings (42 "1.3*sin(2*t)*cos(4*t) - sin(4*t)*sin(t)" function2 EM)) - (text . "\newline\tab{2}{\em Function f3:}") - (bcStrings (42 "2.5*cos(4*t)" function3 EM)) - (text ."\vspace{1}\newline\menuitemstyle{}\tab{2}Enter {\em independent} variable and range:\newline\tab{2} ") - (text ."{\em Variable:}") - (bcStrings (6 t ind SY)) - (text . "ranges {\em from:}") - (bcStrings (9 0 from1 F)) - (text "{\em to:}") - (bcStrings (9 "4*\%pi" to1 F)) - (text - "\indent{0}\vspace{1}\newline\menuitemstyle{}\tab{2} " - "Optionally enter a {\em title} for your surface:") - (bcStrings (15 "knot" title S)) - (text . "\indent{0}") - (doneButton "Continue" bcDraw3DparGen)) - htShowPage() - -bcDraw3DparGen htPage == - fun1 := htpLabelInputString(htPage,'function1) - fun2 := htpLabelInputString(htPage,'function2) - fun3 := htpLabelInputString(htPage,'function3) - ind := htpLabelInputString(htPage,'ind) - from1 := htpLabelInputString(htPage,'from1) - to1 := htpLabelInputString(htPage,'to1) - title := htpLabelInputString(htPage,'title) - curvePart := STRCONC('"curve(",'"{}",fun1,'",{}",fun2,'",{}",fun3,'")") - tubePart := '"{}tubeRadius==.25,{}tubePoints==16" - if (title ^= '"") then - titlePart := (title = '"" => nil; STRCONC('"{}",'"title ==_"",title,'"_"")) - bcFinish('"draw",curvePart,bcDrawIt2(ind,from1,to1),tubePart,titlePart) - else - bcFinish('"draw",curvePart,bcDrawIt2(ind,from1,to1),tubePart) - -bcDraw3Dpar1() == - htInitPage('"Draw Basic Command",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float)) - (isDomain SY (Symbol))) - (text - "\centerline{Drawing a parametrically defined surface:}\newline " - "\centerline{{\em ( f1(u,v), f2(u,v), f3(u,v) )}}\newline " - "\centerline{in terms of three functions {\em f1}, {\em f2}, and {\em f3}}\newline " - "\centerline{and two independent variables {\em u} and {\em v}}\vspace{1}\newline\menuitemstyle{}\tab{2}" - "Enter the three {\em functions} of the independent variables:") - (text . "\newline\tab{2}") - (text . "{\em Function f1:}") - (bcStrings (43 "u*sin(v)" function1 EM)) - (text . "\newline\tab{2}") - (text . "{\em Function f2:}") - (bcStrings (43 "v*cos(u)" function2 EM)) - (text . "\newline\tab{2}") - (text . "{\em Function f3:}") - (bcStrings (43 "u*cos(v)" function3 EM)) - (text . "\newline\menuitemstyle{}\tab{2}Enter independent {\em variables} and ranges:") - (text . "\newline\tab{2}") - (text . "{\em Variable 1:}") - (bcStrings (5 u ind1 SY)) - (text . "ranges {\em from:}") - (bcStrings (9 "-\%pi" from1 F)) - (text . "{\em to:}") - (bcStrings (9 "\%pi" to1 F)) - (text . "\newline\tab{2}") - (text . "{\em Variable 2:}") - (bcStrings (5 v ind2 SY)) - (text . "ranges {\em from:}") - (bcStrings (9 "-\%pi/2" from2 F)) - (text . "{\em to:}") - (bcStrings (9 "\%pi/2" to2 F)) - (text - "\indent{0}\newline\menuitemstyle{}\tab{2} " - "Optionally enter a {\em title} for your surface:") - (bcStrings (15 "surface" title S)) - (text . "\indent{0}")) - htMakeDoneButton ('"Continue",'bcDraw3Dpar1Gen) - htShowPage() - -bcDraw3Dpar1Gen htPage == - fun1 := htpLabelInputString(htPage,'function1) - fun2 := htpLabelInputString(htPage,'function2) - fun3 := htpLabelInputString(htPage,'function3) - ind1 := htpLabelInputString(htPage,'ind1) - from1 := htpLabelInputString(htPage,'from1) - to1 := htpLabelInputString(htPage,'to1) - ind2 := htpLabelInputString(htPage,'ind2) - from2 := htpLabelInputString(htPage,'from2) - to2 := htpLabelInputString(htPage,'to2) - title := htpLabelInputString(htPage,'title) - r1 := bcDrawIt2(ind1,from1,to1) - r2 := bcDrawIt2(ind2,from2,to2) - surfacePart := STRCONC('"surface(",'"{}",fun1,'",{}",fun2,'",{}",fun3,'")") - if (title ^= '"") then - titlePart := (title = '"" => nil; STRCONC('"{}",'"title ==_"",title,'"_"")) - bcFinish('"draw",surfacePart,r1,r2,titlePart) - else - bcFinish('"draw",surfacePart,r1,r2) - -bcSeries() == - htInitPage('"Series Basic Command",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain S (String)) - (isDomain SY (Symbol))) - (text . "Create a series by: ") - (text . "\beginmenu") - (text . "\item ") - (bcLinks ("\menuitemstyle{Expansion}" "" bcSeriesExpansion NILl)) - (text . "\tab{11}Expand a function in a series around a point") - (text . "\item ") - (bcLinks ("\menuitemstyle{Formula}" "" bcSeriesByFormula NIL)) - (text . "\tab{11}Give a formula for the {\em i}'th coefficient") - (text . "\endmenu")) - htShowPage() - -bcSeriesExpansion(a,b) == - htInitPage('"Series Expansion Basic Command",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain EEM (Expression $EmptyMode)) - (isDomain S (String)) - (isDomain SY (Symbol))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em function} you want to expand in a power series") - (text . "\newline\tab{2} ") - (bcStrings (55 "log(cot(x))" function EM)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em power series variable}") - (text . "\tab{49}") - (bcStrings (8 x variable SY)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em point} about which you want to expand") - (text . "\tab{49}") - (bcStrings (8 "\%pi/2" point EM))) - htMakeDoneButton('"Continue",'bcSeriesExpansionGen) - htShowPage() - -bcSeriesExpansionGen htPage == - fun := htpLabelInputString(htPage,'function) - var := htpLabelInputString(htPage,'variable) - point := htpLabelInputString(htPage,'point) - terms := htpLabelInputString(htPage,'numberOfTerms) - bcFinish("series",fun,STRCONC(var,'" = ",point)) - -bcSeriesByFormula(a,b) == - htInitPage('"Power Series Basic Command",nil) - htMakePage '( - (text . "Select the kind of power series you want to create:") - (text . "\beginmenu") - (text . "\item ") - (bcLinks ("\menuitemstyle{Taylor Series}" "" bcTaylorSeries taylor)) - (text . "\newline Series where the exponent ranges over the integers from a {\em non-negative integer} value to plus infinity by an arbitrary {\em positive integer} step size") - (text . "\item ") - (bcLinks ("\menuitemstyle{Laurent Series}" "" bcLaurentSeries laurent)) - (text . "\newline Series where the exponent ranges from an arbitrary {\em integer} value to plus infinity by an arbitrary {\em positive integer} step size") - (text . "\item ") - (bcLinks ("\menuitemstyle{Puiseux Series}" "" bcPuiseuxSeries puiseux)) - (text . "\newline Series where the exponent ranges from an arbitrary {\em rational value} to plus infinity by an arbitrary {\em positive rational number} step size") - (text . "\endmenu")) - htShowPage() - -bcTaylorSeries(a,b) == - htInitPage('"Taylor Series Basic Command",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain EEM (Expression $EmptyMode)) - (isDomain S (String)) - (isDomain SY (Symbol))) - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the formula for the general coefficient of the series") - (text . "\newline\tab{2} ") - (bcStrings (55 "1/factorial(i)" formula EM)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em index variable} for your formula") - (text . "\tab{49}") - (bcStrings (8 i index SY)) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em power series variable}") - (text . "\tab{49}") - (bcStrings (8 x variable SY)) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em point} about which you want to expand") - (text . "\tab{49}") - (bcStrings (8 0 point EM)) - (text . "\blankline ") - (text ."For Taylor Series, the exponent of the power series variable ranges from an {\em initial value}, an arbitrary non-negative integer, to plus infinity; the {\em step size} is any positive integer.") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em initial value} of the index (an integer)") - (text . "\tab{49}") - (bcStrings (8 "0" min I)) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em step size} (a positive integer)") - (text . "\tab{49}") - (bcStrings (8 "1" step PI)) - (doneButton "Continue" bcTaylorSeriesGen)) - htShowPage() - -bcSeriesByFormulaGen htPage == bcNotReady() - -bcLaurentSeries(a,b) == - htInitPage('"Laurent Series Basic Command",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain EEM (Expression $EmptyMode)) - (isDomain S (String)) - (isDomain I (Integer)) - (isDomain PI (PositiveInteger)) - (isDomain SY (Symbol))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the formula for the general coefficient of the series") - (text . "\newline\tab{2} ") - (bcStrings (55 "(-1)**(n - 1)/(n + 2)" formula EM)) - (text . "\vspace{1}\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em index variable} for your formula") - (text . "\tab{49}") - (bcStrings (8 n index SY)) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em power series variable}") - (text . "\tab{49}") - (bcStrings (8 x variable SY)) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em point} about which you want to expand") - (text . "\tab{49}") - (bcStrings (8 0 point F)) - (text . "\blankline") - (text . "\newline For Laurent Series, the exponent of the power series variable ranges from an {\em initial value}, an arbitrary integer value, to plus infinity; the {\em step size} is any positive integer.") - (text . "\blankline") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em initial value} of the index (an integer)") - (text . "\tab{49}") - (bcStrings (8 "-1" min I)) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em step size} (a positive integer)") - (text . "\tab{49}") - (bcStrings (8 "1" step PI)) - (doneButton "Continue" bcLaurentSeriesGen)) - htShowPage() - -bcPuiseuxSeries(a,b) == - htInitPage('"Puiseux Series Basic Command",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain EEM (Expression $EmptyMode)) - (isDomain S (String)) - (isDomain I (Integer)) - (isDomain PI (PositiveInteger)) - (isDOmain RN (Fraction (Integer))) - (isDomain SY (Symbol))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text ."Enter the {\em formula} for the general coefficient of the series") - (text . "\newline\tab{2} ") - (bcStrings(55 "(-1)**((3*n - 4)/6)/factorial(n - 1/3)" formula EM)) - (text . "\vspace{1}\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em index variable} for your formula") - (text . "\tab{49}") - (bcStrings (8 n index SY)) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em power series variable}") - (text . "\tab{49}") - (bcStrings (8 x variable SY)) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em point} about which you want to expand") - (text . "\tab{49}") - (bcStrings (8 0 point F)) - (text . "\blankline ") - (text . "For Puiseux Series, the exponent of the power series variable ranges from an {\em initial value}, an arbitary rational number, to plus infinity; the {\em step size} is an any positive rational number.") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em initial value} of index (a rational number)") - (text . "\tab{51}") - (bcStrings (6 "4/3" min RN)) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em step size} (a positive rational number)") - (text . "\tab{51}") - (bcStrings (6 "2" step RN)) - (doneButton "Continue" bcPuiseuxSeriesGen)) - htShowPage() - -bcTaylorSeriesGen htPage == bcSeriesGen(htPage) - -bcLaurentSeriesGen htPage == - bcSeriesGen(htPage) - -bcPuiseuxSeriesGen htPage == - bcSeriesGen(htPage) - -bcSeriesGen(htPage) == - step:= htpLabelInputString(htPage,'step) - min := htpLabelInputString(htPage,'min) - formula := htpLabelInputString(htPage,'formula) - index := htpLabelInputString(htPage,'index) - var := htpLabelInputString(htPage,'variable) - point := htpLabelInputString(htPage,'point) - varPart := STRCONC(var,'" = ",point) - minPart := STRCONC(min,'"..") - bcFinish('"series",STRCONC(index,'" +-> ",formula),varPart,minPart,step) - -bcLimit() == - htInitPage('"Limit Basic Command",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain S (String)) - (isDomain SY (Symbol))) - (text . "What kind of limit do you want to compute? ") - (text . "\blankline ") - (text . "\beginmenu") - (text . "\item ") - (bcLinks ("\menuitemstyle{A real limit?}" "" bcRealLimit real)) - (text . "\indentrel{17}\tab{0}") - (text . "The limit as the variable approaches a {\em real} value along the real axis") - (text . "\indentrel{-17}") - (text . "\item ") - (text . "\blankline ") - (bcLinks ("\menuitemstyle{A complex limit?}" "" bcComplexLimit complex)) - (text . "\indentrel{17}\tab{0}") - (text . "The limit as the variable approaches a {\em complex} value along any path in the complex plane") - (text . "\indentrel{-17}") - (text . "\endmenu") - ) - htShowPage() - -bcRealLimit(a,b) == - htInitPage('"Real Limit Basic Command",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain SY (Symbol))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em function} you want to compute the limit of:") - (text . "\newline\tab{2} ") - (bcStrings (45 "x*sin(1/x)" expression EM)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the name of the {\em variable}: ") - (text . "\tab{41}") - (bcStrings (6 x variable SY)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Compute the limit at") - (radioButtons location - ("A finite point:" ( - (text . "\tab{33}") - (bcStrings (6 0 point F))) finitePoint) - ("Plus infinity" "" plusInfinity) - ("Minus infinity" "" minusInfinity)) - (doneButton "Continue" bcRealLimitGen)) - htShowPage() - -bcRealLimitGen htPage == - (p := htpButtonValue(htPage,'location)) ^= 'finitePoint => - fun := htpLabelInputString(htPage,'expression) - var := htpLabelInputString(htPage,'variable) - loc := - p = 'plusInfinity => '"%plusInfinity" - '"%minusInfinity" - bcFinish('"limit",fun,STRCONC(var,'" = ",loc)) - page := htInitPage('"Real Limit Basic Command",nil) - htMakePage '( - (text . "Compute the limit") - (lispLinks - ("\menuitemstyle{From both directions}" "" bcRealLimitGen1 both) - ("\menuitemstyle{From the right}" "" bcRealLimitGen1 right) - ("\menuitemstyle{From the left}" "" bcRealLimitGen1 left))) - htpSetProperty(page,'fun,htpLabelInputString(htPage,'expression)) - htpSetProperty(page,'var,htpLabelInputString(htPage,'variable)) - htpSetProperty(page,'loc,htpLabelInputString(htPage,'point)) - htShowPage() - -bcRealLimitGen1(htPage,key) == - direction := - key = 'right => '"_"right_"" - key = 'left => '"_"left_"" - nil - fun := htpProperty(htPage,'fun) - var := htpProperty(htPage,'var) - loc := htpProperty(htPage,'loc) - varPart := STRCONC(var,'" = ",loc) - bcFinish('"limit",fun,varPart,direction) - -bcComplexLimit(a,b) == - htInitPage('"Complex Limit Basic Command",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain SY (Symbol))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em function} you want to compute the limit of:") - (text . "\newline\tab{2} ") - (bcStrings (40 "sin(a*x)/tan(b*x)" expression EM)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the name of the {\em variable}: ") - (text . "\tab{37}") - (bcStrings (5 x variable SY)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Compute the limit at") - (radioButtons location - ("A finite point:" ( - (text . "\newline\space{0}Real part:\space{3}") - (bcStrings (20 0 real F)) - (text . "\newline Complex part:") - (bcStrings (20 0 complex F))) finitePoint) - ("Complex infinity" "" complexInfinity)) - (doneButton "Continue" bcComplexLimitGen)) - htShowPage() - -bcComplexLimitGen htPage == - fun := htpLabelInputString(htPage,'expression) - var := htpLabelInputString(htPage,'variable) - loc := - (p := htpButtonValue(htPage,'location)) = 'finitePoint => - real := htpLabelInputString(htPage,'real) - comp := htpLabelInputString(htPage,'complex) - complexPart := - comp = '"0" => '"" - comp = '"1" => '"%i" - STRCONC(comp,'"*%i") - real = '"0" => - complexPart = '"" => "0" - complexPart - complexPart = '"" => real - STRCONC(real,'" + ",complexPart) - '"%infinity" - varPart := STRCONC(var,'" = ",loc) - bcFinish('"complexLimit",fun,varPart) - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/bc-solve.boot b/src/interp/bc-solve.boot new file mode 100644 index 00000000..29992b8f --- /dev/null +++ b/src/interp/bc-solve.boot @@ -0,0 +1,368 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- 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. + + +import '"bc-matrix" +import '"bc-misc" +)package "BOOT" + + -- HyperTeX basic Solve Command +$systemType := nil +$numberOfEquations := 0 +$solutionMethod := nil + +bcSolve() == + htInitPage('"Solve Basic Command", nil) + htMakePage '( + (text . "What do you want to solve? ") + (text . "\beginmenu") + (text . "\item ") + (bcLinks ("\menuitemstyle{A System Of Linear Equations}" "" bcLinearSolve linear)) + (text . "\item ") + (bcLinks ("\menuitemstyle{A System of Polynomial Equations}" "" bcSystemSolve polynomial)) + (text . "\item ") + (bcLinks ("\menuitemstyle{A Single Polynomial Equation}" "" bcSolveSingle onePolynomial)) + (text . "\endmenu")) + htShowPage() + +bcLinearSolve(p,nn) == + htInitPage('"Basic Solve Command", nil) + htMakePage '( + (text . "How do you want to enter the equations?") + (text . "\beginmenu") + (text . "\item ") + (text . "\newline ") + (bcLinks ("\menuitemstyle{Directly as equations}" "" bcLinearSolveEqns equations)) + (text . "\item ") + (text . "\newline ") + (bcLinks ("\menuitemstyle{In matrix form}" "" bcLinearSolveMatrix matrix)) + (text . "\indentrel{16}\tab{0}") + (text . " \spad{AX = B}, where \spad{A} is a matrix of coefficients and \spad{B} is a vector" ) + (text . "\indentrel{-16}\item ") + (text . "\endmenu")) + htShowPage() + +bcLinearSolveEqns(htPage, p) == + htInitPage('"Basic Solve Command", nil) + htMakePage '( + (domainConditions (isDomain PI (PositiveInteger))) + (inputStrings + ("Enter the {\em number} of equations:" "" 5 2 numberOfEquations PI))) + htMakeDoneButton('"Continue", 'bcLinearSolveEqns1) + htShowPage() + +bcSystemSolve(htPage, p) == + htInitPage('"Basic Solve Command", nil) + htMakePage '( + (domainConditions (isDomain PI (PositiveInteger))) + (inputStrings + ("Enter the {\em number} of equations:" "" 5 2 numberOfEquations PI))) + htMakeDoneButton('"Continue", 'bcSystemSolveEqns1) + htShowPage() + +bcSolveSingle(htPage,p) == + htpSetProperty(htPage,'systemType, 'onePolynomial) + htpSetProperty(htPage,'exitFunction,'bcInputSolveInfo) + bcInputEquations(htPage,'exact) + +bcSystemSolveEqns1 htPage == + htpSetProperty(htPage,'systemType,'polynomial) + htpSetProperty(htPage,'exitFunction,'bcInputSolveInfo) + bcInputEquations(htPage,'exact) + +bcLinearSolveEqns1 htPage == + htpSetProperty(htPage,'systemType,'linear) + htpSetProperty(htPage,'exitFunction,'bcLinearSolveEqnsGen) + bcInputEquations(htPage,'exact) + +bcInputSolveInfo htPage == + page := htInitPage('"Solve Basic Command", htpPropertyList htPage) + htpSetProperty(page,'numberOfEquations,htpProperty(htPage,'numberOfEquations)) + htpSetProperty(page,'inputArea,htpInputAreaAlist htPage) + htMakePage '( + (domainConditions (isDomain PI (PositiveInteger))) + (text . "What would you like?") + (text . "\beginmenu") + (text . "\item ") + (bcLinks ("\menuitemstyle{Exact Solutions}" "" bcSolveEquations exact)) + (text . "\indentrel{18}\tab{0} ") + (text . "Solutions expressed in terms of {\em roots} of irreducible polynomials") + (text . "\indentrel{-18}") + (text . "\item ") + (bcLinks ("\menuitemstyle{Numeric Solutions}" "" bcSolveEquationsNumerically numeric)) + (text . "\indentrel{18}\tab{0} ") + (text . "Solutions expressed in terms of approximate real or complex {\em numbers}") + (text . "\indentrel{-18}") + (text . "\item ") + (bcLinks ("\menuitemstyle{Radical Solutions}" "" bcSolveEquations radical)) + (text . "\indentrel{18}\tab{0} ") + (text . "Solutions expressed in terms of {\em radicals} if it is possible") + (text . "\indentrel{-18}") + (text . "\endmenu")) + htShowPage() + +bcInputEquations(htPage,solutionMethod) == + numEqs := + htpProperty(htPage, 'systemType) = 'onePolynomial => 1 + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage,'numberOfEquations) + objValUnwrap htpLabelSpadValue(htPage, 'numberOfEquations) + linearPred := htpProperty(htPage,'systemType) = 'linear + labelList := + numEqs = 1 => '( + (bcStrings (42 "x^2+1" l1 P)) + (text . " = ") + (bcStrings (6 0 r1 P))) + "append"/[f(i,numEqs,linearPred) for i in 1..numEqs] where f(i,n,linearp) == + spacer := (i > 99 => 0; i > 9 => 1; 2) + prefix := STRCONC('"\newline\tab{2}{\em Equation ",STRINGIMAGE i,'":}") + prefix := STRCONC(prefix,'"\space{",STRINGIMAGE spacer,'"}") + lnam := INTERN STRCONC('"l",STRINGIMAGE i) + rnam := INTERN STRCONC('"r",STRINGIMAGE i) + var:= + linearp => bcMakeLinearEquations(i,n) + bcMakeEquations(i,n) + [['text,:prefix],['bcStrings,[30,var,lnam,'P]],'(text . " = "),['bcStrings,[5,"0",rnam,'P]]] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain PI (PositiveInteger))), + :labelList] + page := htInitPage('"Solve Basic Command", htpPropertyList htPage) + htpSetProperty(page, 'numberOfEquations, numEqs) + htpSetProperty(page, 'solutionMethod,solutionMethod) + htSay '"\newline\menuitemstyle{}\tab{2}" + htSay + numEqs = 1 => '"Enter the {\em Equation}:" + '"Enter the {\em Equations}:" + htSay '"\newline\tab{2}" + htMakePage equationPart + bcHt '"\blankline " + htSay '"\newline\menuitemstyle{}\tab{2}" + htMakePage + numEqs = 1 => '( + (text ."Enter the {\em unknown} (leave blank if implied): ") + (text . "\tab{48}") + (bcStrings (6 "x" unknowns S . quoteString))) + ['(text . "Enter the unknowns (leave blank if implied):"), + '(text . "\tab{44}"), + ['bcStrings, [10,bcMakeUnknowns(numEqs),'unknowns,'P]]] + htMakeDoneButton('"Continue", 'bcInputEquationsEnd) + htShowPage() + +bcCreateVariableString(i) == + STRCONC('"x",STRINGIMAGE i) + +bcMakeUnknowns(number)== + APPLY('CONCAT,[STRCONC(bcCreateVariableString(i)," ") for i in 1..number]) + +bcMakeEquations(i,number)== + number =1 => STRCONC(bcCreateVariableString(1),"^2+1") + bcCreateVariableString(i) + STRCONC( + STRCONC( + APPLY('CONCAT,[STRCONC(bcCreateVariableString(j),"+") for j in 1..number]),"1"), + STRCONC("-2*",STRCONC(bcCreateVariableString(i),"^2"))) + + +bcMakeLinearEquations(i,number)== + number = 1 => bcCreateVariableString(1) + number = 2 => + i=1 => STRCONC(bcCreateVariableString(1),STRCONC("+",bcCreateVariableString(2))) + STRCONC(bcCreateVariableString(1),STRCONC("-",bcCreateVariableString(2))) + STRCONC( + STRCONC( + APPLY('CONCAT,[STRCONC(bcCreateVariableString(j),"+") for j in 1..number]),"1"), + STRCONC("-2*",bcCreateVariableString(i))) + + +bcInputEquationsEnd htPage == + fun := htpProperty(htPage, 'exitFunction) => FUNCALL(fun,htPage) + systemError nil + +bcSolveEquationsNumerically(htPage,p) == + page := htInitPage('"Solve Basic Command", htpPropertyList htPage) + htMakePage '( + (text . "What would you like?") + (radioButtons choice + ("Real roots expressed as rational numbers" "" rr) + ("Real roots expressed as floats" "" rf) + ("Complex roots expressed as rational numbers" "" cr) + ("Complex roots expressed as floats" "" cf)) + (text . "\vspace{1}\newline") + (inputStrings + ("Enter the number of desired {\em digits} of accuracy" "" 5 20 acc PI))) + htMakeDoneButton('"Continue", 'bcSolveNumerically1) + htShowPage() + +bcSolveNumerically1(htPage) == + bcSolveEquations(htPage,'numeric) + +--bcSolveNumerically1(htPage,kind) == +-- htpSetProperty(htPage,'kind,kind) +-- bcSolveEquations(htPage,'numeric) + +bcSolveEquations(htPage,solutionMethod) == + if solutionMethod = 'numeric then + digits := htpLabelInputString(htPage,'acc) + kind := htpButtonValue(htPage,'choice) + accString := + kind in '(rf cf) => STRCONC('"1.e-",digits) + STRCONC('"1/10**",digits) + alist := htpProperty(htPage,'inputArea) + [[.,varpart,:.],:r] := alist + varlist := bcString2WordList varpart + varString := (rest varlist => bcwords2liststring varlist; first varlist) + eqnString := bcGenEquations r + solutionMethod = 'numeric => + name := + kind in '(rf rr) => '"solve" + '"complexSolve" + bcFinish(name,eqnString,accString) + name := + solutionMethod = 'radical => '"radicalSolve" + '"solve" + bcFinish(name,eqnString,varString,accString) + +bcLinearSolveMatrix(htPage,junk) == + bcReadMatrix 'bcLinearSolveMatrix1 + +bcLinearSolveMatrix1 htPage == + page := htInitPage('"Linear Solve Basic Command",htpPropertyList htPage) + htpSetProperty(page,'matrix,bcLinearExtractMatrix htPage) + htMakePage '( + (text . "The right side vector B is:") + (lispLinks + ("Zero:" "the system is homogeneous" bcLinearSolveMatrixHomo homo) + ("Not zero:" "the system is not homogeneous" bcLinearSolveMatrixInhomo nothomo))) + htShowPage() + +bcLinearExtractMatrix htPage == REVERSE htpInputAreaAlist htPage + +bcLinearSolveMatrixInhomo(htPage,junk) == + nrows := htpProperty(htPage,'nrows) + ncols := htpProperty(htPage,'ncols) + labelList := + [f(i) for i in 1..ncols] where f(i) == + spacer := (i > 99 => 0; i > 9 => 1; 2) + prefix := STRCONC('"{\em Coefficient ",STRINGIMAGE i,'":}") + if spacer ^= 0 then + prefix := STRCONC(prefix,'"\space{",STRINGIMAGE spacer,'"}") + name := INTERN STRCONC('"c",STRINGIMAGE i) + [prefix,"",30, 0,name, 'P] + page := htInitPage('"Linear Solve Basic Command",htpPropertyList htPage) + htpSetProperty(page,'matrix,htpProperty(htPage,'matrix)) + htpSetProperty(page,'nrows,nrows) + htpSetProperty(page,'ncols,ncols) + htMakePage [ + '(domainConditions (isDomain P (Polynomial $EmptyMode))), + '(text . "Enter the right side vector B:"), + ['inputStrings, :labelList], + '(text . "\vspace{1}\newline Do you want:" ), + '(lispLinks + ("All the solutions?" "" bcLinearSolveMatrixInhomoGen all) + ("A particular solution?" "" bcLinearSolveMatrixInhomoGen particular))] + htShowPage() + +bcLinearSolveMatrixInhomoGen(htPage,key) == bcLinearMatrixGen(htPage,key) + +bcLinearSolveMatrixHomo(htPage,key) == bcLinearMatrixGen(htPage,'homo) + +bcLinearMatrixGen(htPage,key) == + matform := bcMatrixGen htPage + key = 'homo => bcFinish('"nullSpace",matform) + vector := [x.1 for x in REVERSE htpInputAreaAlist htPage] + vecform := bcVectorGen vector + form := bcMkFunction('"solve",matform,[vecform]) + bcGen + key = 'particular => STRCONC(form,'".particular") + form + +linearFinalRequest(nhh,mat,vect) == + sayBrightly '"Do you want more information on the meaning of the output" + sayBrightly '" (1) no " + sayBrightly '" (2) yes " + tt := bcQueryInteger(1,2,true) + tt=1 => sayBrightly '"Bye Bye" + tt=2 => explainLinear(nhh) + +explainLinear(flag) == + flag="notHomogeneous" => + '("solve returns a particular solution and a basis for" + "the vector space of solutions for the homogeneous part." + "The particular solution is _"failed_" if one cannot be found.") + flag= "homogeneous" => + '("solve returns a basis for" + "the vector space of solutions for the homogeneous part") + systemError nil + +finalExactRequest(equations,unknowns) == + sayBrightly '"Do you like:" + sayBrightly '" (1) the solutions how they are displayed" + sayBrightly '" (2) to get ????" + sayBrightly '" (3) more information on the meaning of the output" + tt := bcQueryInteger(1,3,true) + tt=1 => sayBrightly '"Bye Bye" +-- tt=2 => moreExactSolution(equations,unknowns,flag) + tt=3 => explainExact(equations,unknowns) + +bcLinearSolveEqnsGen htPage == + alist := htpInputAreaAlist htPage + if vars := htpLabelInputString(htPage,'unknowns) then + varlist := bcString2WordList vars + varString := (rest varlist => bcwords2liststring varlist; first varlist) + alist := rest alist --know these are first on the list + eqnString := bcGenEquations alist + bcFinish('"solve",eqnString,varString) + +bcGenEquations alist == + y := alist + while y repeat + right := (first y).1 + y := rest y + left := (first y).1 + y := rest y + eqnlist := [STRCONC(left,'" = ",right),:eqnlist] + rest eqnlist => bcwords2liststring eqnlist + first eqnlist + + + + + + + + + + + diff --git a/src/interp/bc-solve.boot.pamphlet b/src/interp/bc-solve.boot.pamphlet deleted file mode 100644 index 78735cf1..00000000 --- a/src/interp/bc-solve.boot.pamphlet +++ /dev/null @@ -1,388 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp bc-solve.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\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. - -@ -<<*>>= -<> - -import '"bc-matrix" -import '"bc-misc" -)package "BOOT" - - -- HyperTeX basic Solve Command -$systemType := nil -$numberOfEquations := 0 -$solutionMethod := nil - -bcSolve() == - htInitPage('"Solve Basic Command", nil) - htMakePage '( - (text . "What do you want to solve? ") - (text . "\beginmenu") - (text . "\item ") - (bcLinks ("\menuitemstyle{A System Of Linear Equations}" "" bcLinearSolve linear)) - (text . "\item ") - (bcLinks ("\menuitemstyle{A System of Polynomial Equations}" "" bcSystemSolve polynomial)) - (text . "\item ") - (bcLinks ("\menuitemstyle{A Single Polynomial Equation}" "" bcSolveSingle onePolynomial)) - (text . "\endmenu")) - htShowPage() - -bcLinearSolve(p,nn) == - htInitPage('"Basic Solve Command", nil) - htMakePage '( - (text . "How do you want to enter the equations?") - (text . "\beginmenu") - (text . "\item ") - (text . "\newline ") - (bcLinks ("\menuitemstyle{Directly as equations}" "" bcLinearSolveEqns equations)) - (text . "\item ") - (text . "\newline ") - (bcLinks ("\menuitemstyle{In matrix form}" "" bcLinearSolveMatrix matrix)) - (text . "\indentrel{16}\tab{0}") - (text . " \spad{AX = B}, where \spad{A} is a matrix of coefficients and \spad{B} is a vector" ) - (text . "\indentrel{-16}\item ") - (text . "\endmenu")) - htShowPage() - -bcLinearSolveEqns(htPage, p) == - htInitPage('"Basic Solve Command", nil) - htMakePage '( - (domainConditions (isDomain PI (PositiveInteger))) - (inputStrings - ("Enter the {\em number} of equations:" "" 5 2 numberOfEquations PI))) - htMakeDoneButton('"Continue", 'bcLinearSolveEqns1) - htShowPage() - -bcSystemSolve(htPage, p) == - htInitPage('"Basic Solve Command", nil) - htMakePage '( - (domainConditions (isDomain PI (PositiveInteger))) - (inputStrings - ("Enter the {\em number} of equations:" "" 5 2 numberOfEquations PI))) - htMakeDoneButton('"Continue", 'bcSystemSolveEqns1) - htShowPage() - -bcSolveSingle(htPage,p) == - htpSetProperty(htPage,'systemType, 'onePolynomial) - htpSetProperty(htPage,'exitFunction,'bcInputSolveInfo) - bcInputEquations(htPage,'exact) - -bcSystemSolveEqns1 htPage == - htpSetProperty(htPage,'systemType,'polynomial) - htpSetProperty(htPage,'exitFunction,'bcInputSolveInfo) - bcInputEquations(htPage,'exact) - -bcLinearSolveEqns1 htPage == - htpSetProperty(htPage,'systemType,'linear) - htpSetProperty(htPage,'exitFunction,'bcLinearSolveEqnsGen) - bcInputEquations(htPage,'exact) - -bcInputSolveInfo htPage == - page := htInitPage('"Solve Basic Command", htpPropertyList htPage) - htpSetProperty(page,'numberOfEquations,htpProperty(htPage,'numberOfEquations)) - htpSetProperty(page,'inputArea,htpInputAreaAlist htPage) - htMakePage '( - (domainConditions (isDomain PI (PositiveInteger))) - (text . "What would you like?") - (text . "\beginmenu") - (text . "\item ") - (bcLinks ("\menuitemstyle{Exact Solutions}" "" bcSolveEquations exact)) - (text . "\indentrel{18}\tab{0} ") - (text . "Solutions expressed in terms of {\em roots} of irreducible polynomials") - (text . "\indentrel{-18}") - (text . "\item ") - (bcLinks ("\menuitemstyle{Numeric Solutions}" "" bcSolveEquationsNumerically numeric)) - (text . "\indentrel{18}\tab{0} ") - (text . "Solutions expressed in terms of approximate real or complex {\em numbers}") - (text . "\indentrel{-18}") - (text . "\item ") - (bcLinks ("\menuitemstyle{Radical Solutions}" "" bcSolveEquations radical)) - (text . "\indentrel{18}\tab{0} ") - (text . "Solutions expressed in terms of {\em radicals} if it is possible") - (text . "\indentrel{-18}") - (text . "\endmenu")) - htShowPage() - -bcInputEquations(htPage,solutionMethod) == - numEqs := - htpProperty(htPage, 'systemType) = 'onePolynomial => 1 - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage,'numberOfEquations) - objValUnwrap htpLabelSpadValue(htPage, 'numberOfEquations) - linearPred := htpProperty(htPage,'systemType) = 'linear - labelList := - numEqs = 1 => '( - (bcStrings (42 "x^2+1" l1 P)) - (text . " = ") - (bcStrings (6 0 r1 P))) - "append"/[f(i,numEqs,linearPred) for i in 1..numEqs] where f(i,n,linearp) == - spacer := (i > 99 => 0; i > 9 => 1; 2) - prefix := STRCONC('"\newline\tab{2}{\em Equation ",STRINGIMAGE i,'":}") - prefix := STRCONC(prefix,'"\space{",STRINGIMAGE spacer,'"}") - lnam := INTERN STRCONC('"l",STRINGIMAGE i) - rnam := INTERN STRCONC('"r",STRINGIMAGE i) - var:= - linearp => bcMakeLinearEquations(i,n) - bcMakeEquations(i,n) - [['text,:prefix],['bcStrings,[30,var,lnam,'P]],'(text . " = "),['bcStrings,[5,"0",rnam,'P]]] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain PI (PositiveInteger))), - :labelList] - page := htInitPage('"Solve Basic Command", htpPropertyList htPage) - htpSetProperty(page, 'numberOfEquations, numEqs) - htpSetProperty(page, 'solutionMethod,solutionMethod) - htSay '"\newline\menuitemstyle{}\tab{2}" - htSay - numEqs = 1 => '"Enter the {\em Equation}:" - '"Enter the {\em Equations}:" - htSay '"\newline\tab{2}" - htMakePage equationPart - bcHt '"\blankline " - htSay '"\newline\menuitemstyle{}\tab{2}" - htMakePage - numEqs = 1 => '( - (text ."Enter the {\em unknown} (leave blank if implied): ") - (text . "\tab{48}") - (bcStrings (6 "x" unknowns S . quoteString))) - ['(text . "Enter the unknowns (leave blank if implied):"), - '(text . "\tab{44}"), - ['bcStrings, [10,bcMakeUnknowns(numEqs),'unknowns,'P]]] - htMakeDoneButton('"Continue", 'bcInputEquationsEnd) - htShowPage() - -bcCreateVariableString(i) == - STRCONC('"x",STRINGIMAGE i) - -bcMakeUnknowns(number)== - APPLY('CONCAT,[STRCONC(bcCreateVariableString(i)," ") for i in 1..number]) - -bcMakeEquations(i,number)== - number =1 => STRCONC(bcCreateVariableString(1),"^2+1") - bcCreateVariableString(i) - STRCONC( - STRCONC( - APPLY('CONCAT,[STRCONC(bcCreateVariableString(j),"+") for j in 1..number]),"1"), - STRCONC("-2*",STRCONC(bcCreateVariableString(i),"^2"))) - - -bcMakeLinearEquations(i,number)== - number = 1 => bcCreateVariableString(1) - number = 2 => - i=1 => STRCONC(bcCreateVariableString(1),STRCONC("+",bcCreateVariableString(2))) - STRCONC(bcCreateVariableString(1),STRCONC("-",bcCreateVariableString(2))) - STRCONC( - STRCONC( - APPLY('CONCAT,[STRCONC(bcCreateVariableString(j),"+") for j in 1..number]),"1"), - STRCONC("-2*",bcCreateVariableString(i))) - - -bcInputEquationsEnd htPage == - fun := htpProperty(htPage, 'exitFunction) => FUNCALL(fun,htPage) - systemError nil - -bcSolveEquationsNumerically(htPage,p) == - page := htInitPage('"Solve Basic Command", htpPropertyList htPage) - htMakePage '( - (text . "What would you like?") - (radioButtons choice - ("Real roots expressed as rational numbers" "" rr) - ("Real roots expressed as floats" "" rf) - ("Complex roots expressed as rational numbers" "" cr) - ("Complex roots expressed as floats" "" cf)) - (text . "\vspace{1}\newline") - (inputStrings - ("Enter the number of desired {\em digits} of accuracy" "" 5 20 acc PI))) - htMakeDoneButton('"Continue", 'bcSolveNumerically1) - htShowPage() - -bcSolveNumerically1(htPage) == - bcSolveEquations(htPage,'numeric) - ---bcSolveNumerically1(htPage,kind) == --- htpSetProperty(htPage,'kind,kind) --- bcSolveEquations(htPage,'numeric) - -bcSolveEquations(htPage,solutionMethod) == - if solutionMethod = 'numeric then - digits := htpLabelInputString(htPage,'acc) - kind := htpButtonValue(htPage,'choice) - accString := - kind in '(rf cf) => STRCONC('"1.e-",digits) - STRCONC('"1/10**",digits) - alist := htpProperty(htPage,'inputArea) - [[.,varpart,:.],:r] := alist - varlist := bcString2WordList varpart - varString := (rest varlist => bcwords2liststring varlist; first varlist) - eqnString := bcGenEquations r - solutionMethod = 'numeric => - name := - kind in '(rf rr) => '"solve" - '"complexSolve" - bcFinish(name,eqnString,accString) - name := - solutionMethod = 'radical => '"radicalSolve" - '"solve" - bcFinish(name,eqnString,varString,accString) - -bcLinearSolveMatrix(htPage,junk) == - bcReadMatrix 'bcLinearSolveMatrix1 - -bcLinearSolveMatrix1 htPage == - page := htInitPage('"Linear Solve Basic Command",htpPropertyList htPage) - htpSetProperty(page,'matrix,bcLinearExtractMatrix htPage) - htMakePage '( - (text . "The right side vector B is:") - (lispLinks - ("Zero:" "the system is homogeneous" bcLinearSolveMatrixHomo homo) - ("Not zero:" "the system is not homogeneous" bcLinearSolveMatrixInhomo nothomo))) - htShowPage() - -bcLinearExtractMatrix htPage == REVERSE htpInputAreaAlist htPage - -bcLinearSolveMatrixInhomo(htPage,junk) == - nrows := htpProperty(htPage,'nrows) - ncols := htpProperty(htPage,'ncols) - labelList := - [f(i) for i in 1..ncols] where f(i) == - spacer := (i > 99 => 0; i > 9 => 1; 2) - prefix := STRCONC('"{\em Coefficient ",STRINGIMAGE i,'":}") - if spacer ^= 0 then - prefix := STRCONC(prefix,'"\space{",STRINGIMAGE spacer,'"}") - name := INTERN STRCONC('"c",STRINGIMAGE i) - [prefix,"",30, 0,name, 'P] - page := htInitPage('"Linear Solve Basic Command",htpPropertyList htPage) - htpSetProperty(page,'matrix,htpProperty(htPage,'matrix)) - htpSetProperty(page,'nrows,nrows) - htpSetProperty(page,'ncols,ncols) - htMakePage [ - '(domainConditions (isDomain P (Polynomial $EmptyMode))), - '(text . "Enter the right side vector B:"), - ['inputStrings, :labelList], - '(text . "\vspace{1}\newline Do you want:" ), - '(lispLinks - ("All the solutions?" "" bcLinearSolveMatrixInhomoGen all) - ("A particular solution?" "" bcLinearSolveMatrixInhomoGen particular))] - htShowPage() - -bcLinearSolveMatrixInhomoGen(htPage,key) == bcLinearMatrixGen(htPage,key) - -bcLinearSolveMatrixHomo(htPage,key) == bcLinearMatrixGen(htPage,'homo) - -bcLinearMatrixGen(htPage,key) == - matform := bcMatrixGen htPage - key = 'homo => bcFinish('"nullSpace",matform) - vector := [x.1 for x in REVERSE htpInputAreaAlist htPage] - vecform := bcVectorGen vector - form := bcMkFunction('"solve",matform,[vecform]) - bcGen - key = 'particular => STRCONC(form,'".particular") - form - -linearFinalRequest(nhh,mat,vect) == - sayBrightly '"Do you want more information on the meaning of the output" - sayBrightly '" (1) no " - sayBrightly '" (2) yes " - tt := bcQueryInteger(1,2,true) - tt=1 => sayBrightly '"Bye Bye" - tt=2 => explainLinear(nhh) - -explainLinear(flag) == - flag="notHomogeneous" => - '("solve returns a particular solution and a basis for" - "the vector space of solutions for the homogeneous part." - "The particular solution is _"failed_" if one cannot be found.") - flag= "homogeneous" => - '("solve returns a basis for" - "the vector space of solutions for the homogeneous part") - systemError nil - -finalExactRequest(equations,unknowns) == - sayBrightly '"Do you like:" - sayBrightly '" (1) the solutions how they are displayed" - sayBrightly '" (2) to get ????" - sayBrightly '" (3) more information on the meaning of the output" - tt := bcQueryInteger(1,3,true) - tt=1 => sayBrightly '"Bye Bye" --- tt=2 => moreExactSolution(equations,unknowns,flag) - tt=3 => explainExact(equations,unknowns) - -bcLinearSolveEqnsGen htPage == - alist := htpInputAreaAlist htPage - if vars := htpLabelInputString(htPage,'unknowns) then - varlist := bcString2WordList vars - varString := (rest varlist => bcwords2liststring varlist; first varlist) - alist := rest alist --know these are first on the list - eqnString := bcGenEquations alist - bcFinish('"solve",eqnString,varString) - -bcGenEquations alist == - y := alist - while y repeat - right := (first y).1 - y := rest y - left := (first y).1 - y := rest y - eqnlist := [STRCONC(left,'" = ",right),:eqnlist] - rest eqnlist => bcwords2liststring eqnlist - first eqnlist - - - - - - - - - - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/bc-util.boot b/src/interp/bc-util.boot new file mode 100644 index 00000000..70b8df52 --- /dev/null +++ b/src/interp/bc-util.boot @@ -0,0 +1,130 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- 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. + + +import '"ht-util" +)package "BOOT" + +bcFinish(name,arg,:args) == bcGen bcMkFunction(name,arg,args) + +bcMkFunction(name,arg,args) == + args := [x for x in args | x] + STRCONC(name,'"(",arg,"STRCONC"/[STRCONC('",", x) for x in args],'")") + +bcString2HyString2 s == + (STRINGP s) and (s.0 = char '_") => + len := #s + STRCONC('"\_"", SUBSTRING(s, 1, len-2), '"\_"") + s + +bcString2HyString s == s + +bcFindString(s,i,n,char) == or/[j for j in i..n | s.j = char] + +bcGen command == + htInitPage('"Basic Command",nil) + string := + #command < 50 => STRCONC('"{\centerline{\tt ",command,'" }}") + STRCONC('"{\tt ",command,'" }") + htMakePage [ + '(text + "{Here is the AXIOM command you could have issued to compute this result:}" + "\vspace{2}\newline "), + ['text,:string]] + htMakeDoitButton('"Do It", command) + htShowPage() + +-- bcGen for axiom - nag link +linkGen command == + htInitPage('"AXIOM-Nag Link Command",nil) + string := + #command < 50 => STRCONC('"{\centerline{ ",command,'" }}") + command + htMakePage [ + '(text + "\centerline{{\em Here is the AXIOM command}}" + "\centerline{{\em you could have issued to compute this result:}}" + "\vspace{2}\newline "), + ['text,:string]] + htMakeDoitButton('"Do It", command) + htShowPage() + +bcOptional s == + s = '"" => '"2" + s + +bcvspace() == bcHt '"\vspace{1}\newline " + +bcString2WordList s == fn(s,0,MAXINDEX s) where + fn(s,i,n) == + i > n => nil + k := or/[j for j in i..n | s.j ^= char '_ ] + null INTEGERP k => nil + l := bcFindString(s,k + 1,n,char '_ ) + null INTEGERP l => [SUBSTRING(s,k,nil)] + [SUBSTRING(s,k,l-k),:fn(s,l + 1,n)] + + +bcwords2liststring u == + null u => nil + STRCONC('"[",first u,fn rest u) where + fn(u) == + null u => '"]" + STRCONC('", ",first u,fn rest u) + +bcVectorGen vec == bcwords2liststring vec + +bcError string == + sayBrightlyNT '"NOTE: " + sayBrightly string + +bcDrawIt(ind,a,b) == STRCONC(ind,'"=",a,'"..",b) + +bcNotReady htPage == + htInitPage('"Basic Command",nil) + htMakePage '( + (text . + "{\centerline{\em This facility will soon be available}}")) + htShowPage() + +htStringPad(n,w) == + s := STRINGIMAGE n + ws := #s + STRCONC('"\space{",STRINGIMAGE (w - ws + 1),'"}",s) + +stringList2String x == + null x => '"()" + STRCONC('"(",first x,"STRCONC"/[STRCONC('",",y) for y in rest x],'")") + +htMkName(s,n) == STRCONC(s,STRINGIMAGE n) + diff --git a/src/interp/bc-util.boot.pamphlet b/src/interp/bc-util.boot.pamphlet deleted file mode 100644 index 831563d6..00000000 --- a/src/interp/bc-util.boot.pamphlet +++ /dev/null @@ -1,150 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp bc-util.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\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. - -@ -<<*>>= -<> - -import '"ht-util" -)package "BOOT" - -bcFinish(name,arg,:args) == bcGen bcMkFunction(name,arg,args) - -bcMkFunction(name,arg,args) == - args := [x for x in args | x] - STRCONC(name,'"(",arg,"STRCONC"/[STRCONC('",", x) for x in args],'")") - -bcString2HyString2 s == - (STRINGP s) and (s.0 = char '_") => - len := #s - STRCONC('"\_"", SUBSTRING(s, 1, len-2), '"\_"") - s - -bcString2HyString s == s - -bcFindString(s,i,n,char) == or/[j for j in i..n | s.j = char] - -bcGen command == - htInitPage('"Basic Command",nil) - string := - #command < 50 => STRCONC('"{\centerline{\tt ",command,'" }}") - STRCONC('"{\tt ",command,'" }") - htMakePage [ - '(text - "{Here is the AXIOM command you could have issued to compute this result:}" - "\vspace{2}\newline "), - ['text,:string]] - htMakeDoitButton('"Do It", command) - htShowPage() - --- bcGen for axiom - nag link -linkGen command == - htInitPage('"AXIOM-Nag Link Command",nil) - string := - #command < 50 => STRCONC('"{\centerline{ ",command,'" }}") - command - htMakePage [ - '(text - "\centerline{{\em Here is the AXIOM command}}" - "\centerline{{\em you could have issued to compute this result:}}" - "\vspace{2}\newline "), - ['text,:string]] - htMakeDoitButton('"Do It", command) - htShowPage() - -bcOptional s == - s = '"" => '"2" - s - -bcvspace() == bcHt '"\vspace{1}\newline " - -bcString2WordList s == fn(s,0,MAXINDEX s) where - fn(s,i,n) == - i > n => nil - k := or/[j for j in i..n | s.j ^= char '_ ] - null INTEGERP k => nil - l := bcFindString(s,k + 1,n,char '_ ) - null INTEGERP l => [SUBSTRING(s,k,nil)] - [SUBSTRING(s,k,l-k),:fn(s,l + 1,n)] - - -bcwords2liststring u == - null u => nil - STRCONC('"[",first u,fn rest u) where - fn(u) == - null u => '"]" - STRCONC('", ",first u,fn rest u) - -bcVectorGen vec == bcwords2liststring vec - -bcError string == - sayBrightlyNT '"NOTE: " - sayBrightly string - -bcDrawIt(ind,a,b) == STRCONC(ind,'"=",a,'"..",b) - -bcNotReady htPage == - htInitPage('"Basic Command",nil) - htMakePage '( - (text . - "{\centerline{\em This facility will soon be available}}")) - htShowPage() - -htStringPad(n,w) == - s := STRINGIMAGE n - ws := #s - STRCONC('"\space{",STRINGIMAGE (w - ws + 1),'"}",s) - -stringList2String x == - null x => '"()" - STRCONC('"(",first x,"STRCONC"/[STRCONC('",",y) for y in rest x],'")") - -htMkName(s,n) == STRCONC(s,STRINGIMAGE n) - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/buildom.boot b/src/interp/buildom.boot new file mode 100644 index 00000000..11e96b24 --- /dev/null +++ b/src/interp/buildom.boot @@ -0,0 +1,366 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- 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. + + +-- This file contains the constructors for the domains that cannot +-- be written in ScratchpadII yet. They are not cached because they +-- are very cheap to instantiate. +-- SMW and SCM July 86 + +import '"sys-macros" +)package "BOOT" + +$noCategoryDomains == '(Domain Mode SubDomain) +$nonLisplibDomains == APPEND($Primitives,$noCategoryDomains) + +--% Record +-- Want to eventually have the elts and setelts. +-- Record is a macro in BUILDOM LISP. It takes out the colons. + +isRecord type == type is ["Record",:.] + +RecordInner args == + -- this is old and should be removed wherever it occurs + if $evalDomain then + sayBrightly '"-->> Whoops! RecordInner called from this code." + Record0 VEC2LIST args + +Record0 args == + dom := GETREFV 10 + -- JHD added an extra slot to cache EQUAL methods + dom.0 := ["Record", :[["_:", CAR a, devaluate CDR a] for a in args]] + dom.1 := + [function lookupInTable,dom, + [["_=",[[["Boolean"],"_$","_$"],:12]], + ["coerce",[[$Expression,"_$"],:14]]]] + dom.2 := NIL + dom.3 := ["RecordCategory",:QCDR dom.0] + dom.4 := + [[ '(SetCategory) ],[ '(SetCategory) ]] + dom.5 := [CDR a for a in args] + dom.6 := [function RecordEqual, :dom] + dom.7 := [function RecordPrint, :dom] + dom.8 := [function Undef, :dom] + -- following is cache for equality functions + dom.9 := if (n:= LENGTH args) <= 2 + then [NIL,:NIL] + else GETREFV n + dom + +RecordEqual(x,y,dom) == + PAIRP x => + b:= + SPADCALL(CAR x, CAR y, CAR(dom.9) or + CAR RPLACA(dom.9,findEqualFun(dom.5.0))) + NULL rest(dom.5) => b + b and + SPADCALL(CDR x, CDR y, CDR (dom.9) or + CDR RPLACD(dom.9,findEqualFun(dom.5.1))) + VECP x => + equalfuns := dom.9 + and/[SPADCALL(x.i,y.i,equalfuns.i or (equalfuns.i:=findEqualFun(fdom))) + for i in 0.. for fdom in dom.5] + error '"Bug: Silly record representation" + +RecordPrint(x,dom) == coerceRe2E(x,dom.3) + +coerceVal2E(x,m) == + objValUnwrap coerceByFunction(objNewWrap(x,m),$Expression) + +findEqualFun(dom) == + compiledLookup("_=",[$Boolean,"$","$"],dom) + +coerceRe2E(x,source) == + n := # CDR source + n = 1 => + ["construct", + ["_=", source.1.1, coerceVal2E(CAR x,source.1.2)] ] + n = 2 => + ["construct", + ["_=", source.1.1, coerceVal2E(CAR x,source.1.2)], _ + ["_=", source.2.1, coerceVal2E(CDR x,source.2.2)] ] + VECP x => + ['construct, + :[["_=",tag,coerceVal2E(x.i, fdom)] + for i in 0.. for [.,tag,fdom] in rest source]] + error '"Bug: ridiculous record representation" + + +--% Union +-- Want to eventually have the coerce to and from branch types. + +Union(:args) == + dom := GETREFV 9 + dom.0 := ["Union", :[(if a is ["_:",tag,domval] then ["_:",tag,devaluate domval] + else devaluate a) for a in args]] + dom.1 := + [function lookupInTable,dom, + [["_=",[[["Boolean"],"_$","_$"],:12]], + ["coerce",[[$Expression,"_$"],:14]]]] + dom.2 := NIL + dom.3 := + '(SetCategory) + dom.4 := + [[ '(SetCategory) ],[ '(SetCategory) ]] + dom.5 := args + dom.6 := [function UnionEqual, :dom] + dom.7 := [function UnionPrint, :dom] + dom.8 := [function Undef, :dom] + dom + +UnionEqual(x, y, dom) == + ["Union",:branches] := dom.0 + branches := orderUnionEntries branches + predlist := mkPredList branches + same := false + for b in stripUnionTags branches for p in predlist while not same repeat + typeFun := ["LAMBDA", '(_#1), p] + FUNCALL(typeFun,x) and FUNCALL(typeFun,y) => + STRINGP b => same := (x = y) + if p is ["EQCAR", :.] then (x := rest x; y := rest y) + same := SPADCALL(x, y, findEqualFun(evalDomain b)) + same + +UnionPrint(x, dom) == coerceUn2E(x, dom.0) + +coerceUn2E(x,source) == + ["Union",:branches] := source + branches := orderUnionEntries branches + predlist := mkPredList branches + byGeorge := byJane := GENSYM() + for b in stripUnionTags branches for p in predlist repeat + typeFun := ["LAMBDA", '(_#1), p] + if FUNCALL(typeFun,x) then return + if p is ["EQCAR", :.] then x := rest x +-- STRINGP b => return x -- to catch "failed" etc. + STRINGP b => byGeorge := x -- to catch "failed" etc. + byGeorge := coerceVal2E(x,b) + byGeorge = byJane => + error '"Union bug: Cannot find appropriate branch for coerce to E" + byGeorge + +--% Mapping +-- Want to eventually have elt: ($, args) -> target + +Mapping(:args) == + dom := GETREFV 9 + dom.0 := ["Mapping", :[devaluate a for a in args]] + dom.1 := + [function lookupInTable,dom, + [["_=",[[["Boolean"],"_$","_$"],:12]], + ["coerce",[[$Expression,"_$"],:14]]]] + dom.2 := NIL + dom.3 := + '(SetCategory) + dom.4 := + [[ '(SetCategory) ],[ '(SetCategory) ]] + dom.5 := args + dom.6 := [function MappingEqual, :dom] + dom.7 := [function MappingPrint, :dom] + dom.8 := [function Undef, :dom] + dom + +MappingEqual(x, y, dom) == EQ(x,y) +MappingPrint(x, dom) == coerceMap2E(x) + +coerceMap2E(x) == + -- nrlib domain + ARRAYP CDR x => ["theMap", BPINAME CAR x, + if $testingSystem then 0 else REMAINDER(HASHEQ CDR x, 1000)] + -- aldor + ["theMap", BPINAME CAR x ] + +--% Enumeration + +Enumeration(:"args") == + dom := GETREFV 9 + -- JHD added an extra slot to cache EQUAL methods + dom.0 := ["Enumeration", :args] + dom.1 := + [function lookupInTable,dom, + [["_=",[[["Boolean"],"_$","_$"],:12]], + ["coerce",[[$Expression,"_$"],:14], [["_$", $Symbol], :16]] + ]] + dom.2 := NIL + dom.3 := ["EnumerationCategory",:QCDR dom.0] + dom.4 := + [[ '(SetCategory) ],[ '(SetCategory) ]] + dom.5 := args + dom.6 := [function EnumEqual, :dom] + dom.7 := [function EnumPrint, :dom] + dom.8 := [function createEnum, :dom] + dom + +EnumEqual(e1,e2,dom) == e1=e2 +EnumPrint(enum, dom) == dom.5.enum +createEnum(sym, dom) == + args := dom.5 + val := -1 + for v in args for i in 0.. repeat + sym=v => return(val:=i) + val<0 => error ["Cannot coerce",sym,"to",["Enumeration",:args]] + val + +--% INSTANTIATORS + +RecordCategory(:"x") == constructorCategory ["Record",:x] + +EnumerationCategory(:"x") == constructorCategory ["Enumeration",:x] + +UnionCategory(:"x") == constructorCategory ["Union",:x] + +--ListCategory(:"x") == constructorCategory ("List",:x) + +--VectorCategory(:"x") == constructorCategory ("Vector",:x) + --above two now defined in SPAD code. + +constructorCategory (title is [op,:.]) == + constructorFunction:= GETL(op,"makeFunctionList") or + systemErrorHere '"constructorCategory" + [funlist,.]:= FUNCALL(constructorFunction,"$",title,$CategoryFrame) + oplist:= [[[a,b],true,c] for [a,b,c] in funlist] + cat:= + JoinInner([SetCategory(),mkCategory("domain",oplist,nil,nil,nil)], + $EmptyEnvironment) + cat.(0):= title + cat + +--mkMappingFunList(nam,mapForm,e) == [[],e] +mkMappingFunList(nam,mapForm,e) == + dc := GENSYM() + sigFunAlist:= + [["_=",[["Boolean"],nam ,nam],["ELT",dc,6]], + ["coerce",[$Expression,nam],["ELT",dc,7]]] + [substitute(nam,dc,substitute("$",'Rep,sigFunAlist)),e] + +mkRecordFunList(nam,["Record",:Alist],e) == + len:= #Alist + +-- for (.,a,.) in Alist do +-- if getmode(a,e) then MOAN("Symbol: ",a, +-- " must not be both a variable and literal") +-- e:= put(a,"isLiteral","true",e) + dc := GENSYM() + sigFunAlist:= + --:((a,(A,nam),("XLAM",("$1","$2"),("RECORDELT","$1",i,len))) + -- for i in 0..,(.,a,A) in Alist), + + [["construct",[nam,:[A for [.,a,A] in Alist]],"mkRecord"], + ["_=",[["Boolean"],nam ,nam],["ELT",dc,6]], + ["coerce",[$Expression,nam],["ELT",dc,7]],: + [["elt",[A,nam,PNAME a],["XLAM",["$1","$2"],["RECORDELT","$1",i,len]]] + for i in 0.. for [.,a,A] in Alist],: + [["setelt",[A,nam,PNAME a,A],["XLAM",["$1","$2","$3"], + ["SETRECORDELT","$1",i, len,"$3"]]] + for i in 0.. for [.,a,A] in Alist],: + [["copy",[nam,nam],["XLAM",["$1"],["RECORDCOPY", + "$1",len]]]]] + [substitute(nam,dc,substitute("$","Rep",sigFunAlist)),e] + +mkNewUnionFunList(name,form is ["Union",:listOfEntries],e) == + dc := name + if name = "Rep" then name := "$" + --2. create coercions from subtypes to subUnion + cList:= + [["_=",[["Boolean"],name ,name],["ELT",dc,6]], + ["coerce",[$Expression,name],["ELT",dc,7]],: + ("append"/ + [[["construct",[name,type],["XLAM",["#1"],["CONS",i,"#1"]]], + ["elt",[type,name,tag],cdownFun], + ["case",['(Boolean),name,tag], + ["XLAM",["#1"],["QEQCAR","#1",i]]]] + for [.,tag,type] in listOfEntries for i in 0..])] where + cdownFun() == + gg:=GENSYM() + $InteractiveMode => + ["XLAM",["#1"],["PROG1",["QCDR","#1"], + ["check_-union",["QEQCAR","#1",i],type,"#1"]]] + ["XLAM",["#1"],["PROG2",["LET",gg,"#1"],["QCDR",gg], + ["check_-union",["QEQCAR",gg,i],type,gg]]] + [cList,e] + +mkEnumerationFunList(nam,["Enumeration",:SL],e) == + len:= #SL + dc := nam + cList := + [nil, + ["_=",[["Boolean"],nam ,nam],["ELT",dc,6]], + ["_^_=",[["Boolean"],nam ,nam],["ELT",dc,7]], + ["coerce",[nam, ["Symbol"]], ["ELT", dc, 8]], + ["coerce",[["OutputForm"],nam],["ELT",dc, 9]]] + [substitute(nam, dc, cList),e] + +mkUnionFunList(op,form is ["Union",:listOfEntries],e) == + first listOfEntries is [":",.,.] => mkNewUnionFunList(op,form,e) + -- following call to order is a bug, but needs massive recomp to fix + listOfEntries:= orderUnionEntries listOfEntries + --1. create representations of subtypes + predList:= mkPredList listOfEntries + g:=GENSYM() + --2. create coercions from subtypes to subUnion + cList:= + [["_=",[["Boolean"],g ,g],["ELT",op,6]], + ["coerce",[$Expression,g],["ELT",op,7]],: + ("append"/ + [[["autoCoerce",[g,t],upFun], + ["coerce",[t,g],cdownFun], + ["autoCoerce",[t,g],downFun], --this should be removed eventually + ["case",['(Boolean),g,t],typeFun]] + for p in predList for t in listOfEntries])] where + upFun() == + p is ["EQCAR",x,n] => ["XLAM",["#1"],["CONS",n,"#1"]] + ["XLAM",["#1"],"#1"] + cdownFun() == + gg:=GENSYM() + if p is ["EQCAR",x,n] then + ref:=["QCDR",gg] + q:= ["QEQCAR", gg, n] + else + ref:=gg + q:= substitute(gg,"#1",p) + ["XLAM",["#1"],["PROG2",["LET",gg,"#1"],ref, + ["check_-union",q,t,gg]]] + downFun() == + p is ["EQCAR",x,.] => + ["XLAM",["#1"],["QCDR","#1"]] + ["XLAM",["#1"],"#1"] + typeFun() == + p is ["EQCAR",x,n] => + ["XLAM",["#1"],["QEQCAR",x,n]] + ["XLAM",["#1"],p] + op:= + op="Rep" => "$" + op + cList:= substitute(op,g,cList) + [cList,e] + diff --git a/src/interp/buildom.boot.pamphlet b/src/interp/buildom.boot.pamphlet deleted file mode 100644 index cbbc7a43..00000000 --- a/src/interp/buildom.boot.pamphlet +++ /dev/null @@ -1,386 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp buildom.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\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. - -@ -<<*>>= -<> - --- This file contains the constructors for the domains that cannot --- be written in ScratchpadII yet. They are not cached because they --- are very cheap to instantiate. --- SMW and SCM July 86 - -import '"sys-macros" -)package "BOOT" - -$noCategoryDomains == '(Domain Mode SubDomain) -$nonLisplibDomains == APPEND($Primitives,$noCategoryDomains) - ---% Record --- Want to eventually have the elts and setelts. --- Record is a macro in BUILDOM LISP. It takes out the colons. - -isRecord type == type is ["Record",:.] - -RecordInner args == - -- this is old and should be removed wherever it occurs - if $evalDomain then - sayBrightly '"-->> Whoops! RecordInner called from this code." - Record0 VEC2LIST args - -Record0 args == - dom := GETREFV 10 - -- JHD added an extra slot to cache EQUAL methods - dom.0 := ["Record", :[["_:", CAR a, devaluate CDR a] for a in args]] - dom.1 := - [function lookupInTable,dom, - [["_=",[[["Boolean"],"_$","_$"],:12]], - ["coerce",[[$Expression,"_$"],:14]]]] - dom.2 := NIL - dom.3 := ["RecordCategory",:QCDR dom.0] - dom.4 := - [[ '(SetCategory) ],[ '(SetCategory) ]] - dom.5 := [CDR a for a in args] - dom.6 := [function RecordEqual, :dom] - dom.7 := [function RecordPrint, :dom] - dom.8 := [function Undef, :dom] - -- following is cache for equality functions - dom.9 := if (n:= LENGTH args) <= 2 - then [NIL,:NIL] - else GETREFV n - dom - -RecordEqual(x,y,dom) == - PAIRP x => - b:= - SPADCALL(CAR x, CAR y, CAR(dom.9) or - CAR RPLACA(dom.9,findEqualFun(dom.5.0))) - NULL rest(dom.5) => b - b and - SPADCALL(CDR x, CDR y, CDR (dom.9) or - CDR RPLACD(dom.9,findEqualFun(dom.5.1))) - VECP x => - equalfuns := dom.9 - and/[SPADCALL(x.i,y.i,equalfuns.i or (equalfuns.i:=findEqualFun(fdom))) - for i in 0.. for fdom in dom.5] - error '"Bug: Silly record representation" - -RecordPrint(x,dom) == coerceRe2E(x,dom.3) - -coerceVal2E(x,m) == - objValUnwrap coerceByFunction(objNewWrap(x,m),$Expression) - -findEqualFun(dom) == - compiledLookup("_=",[$Boolean,"$","$"],dom) - -coerceRe2E(x,source) == - n := # CDR source - n = 1 => - ["construct", - ["_=", source.1.1, coerceVal2E(CAR x,source.1.2)] ] - n = 2 => - ["construct", - ["_=", source.1.1, coerceVal2E(CAR x,source.1.2)], _ - ["_=", source.2.1, coerceVal2E(CDR x,source.2.2)] ] - VECP x => - ['construct, - :[["_=",tag,coerceVal2E(x.i, fdom)] - for i in 0.. for [.,tag,fdom] in rest source]] - error '"Bug: ridiculous record representation" - - ---% Union --- Want to eventually have the coerce to and from branch types. - -Union(:args) == - dom := GETREFV 9 - dom.0 := ["Union", :[(if a is ["_:",tag,domval] then ["_:",tag,devaluate domval] - else devaluate a) for a in args]] - dom.1 := - [function lookupInTable,dom, - [["_=",[[["Boolean"],"_$","_$"],:12]], - ["coerce",[[$Expression,"_$"],:14]]]] - dom.2 := NIL - dom.3 := - '(SetCategory) - dom.4 := - [[ '(SetCategory) ],[ '(SetCategory) ]] - dom.5 := args - dom.6 := [function UnionEqual, :dom] - dom.7 := [function UnionPrint, :dom] - dom.8 := [function Undef, :dom] - dom - -UnionEqual(x, y, dom) == - ["Union",:branches] := dom.0 - branches := orderUnionEntries branches - predlist := mkPredList branches - same := false - for b in stripUnionTags branches for p in predlist while not same repeat - typeFun := ["LAMBDA", '(_#1), p] - FUNCALL(typeFun,x) and FUNCALL(typeFun,y) => - STRINGP b => same := (x = y) - if p is ["EQCAR", :.] then (x := rest x; y := rest y) - same := SPADCALL(x, y, findEqualFun(evalDomain b)) - same - -UnionPrint(x, dom) == coerceUn2E(x, dom.0) - -coerceUn2E(x,source) == - ["Union",:branches] := source - branches := orderUnionEntries branches - predlist := mkPredList branches - byGeorge := byJane := GENSYM() - for b in stripUnionTags branches for p in predlist repeat - typeFun := ["LAMBDA", '(_#1), p] - if FUNCALL(typeFun,x) then return - if p is ["EQCAR", :.] then x := rest x --- STRINGP b => return x -- to catch "failed" etc. - STRINGP b => byGeorge := x -- to catch "failed" etc. - byGeorge := coerceVal2E(x,b) - byGeorge = byJane => - error '"Union bug: Cannot find appropriate branch for coerce to E" - byGeorge - ---% Mapping --- Want to eventually have elt: ($, args) -> target - -Mapping(:args) == - dom := GETREFV 9 - dom.0 := ["Mapping", :[devaluate a for a in args]] - dom.1 := - [function lookupInTable,dom, - [["_=",[[["Boolean"],"_$","_$"],:12]], - ["coerce",[[$Expression,"_$"],:14]]]] - dom.2 := NIL - dom.3 := - '(SetCategory) - dom.4 := - [[ '(SetCategory) ],[ '(SetCategory) ]] - dom.5 := args - dom.6 := [function MappingEqual, :dom] - dom.7 := [function MappingPrint, :dom] - dom.8 := [function Undef, :dom] - dom - -MappingEqual(x, y, dom) == EQ(x,y) -MappingPrint(x, dom) == coerceMap2E(x) - -coerceMap2E(x) == - -- nrlib domain - ARRAYP CDR x => ["theMap", BPINAME CAR x, - if $testingSystem then 0 else REMAINDER(HASHEQ CDR x, 1000)] - -- aldor - ["theMap", BPINAME CAR x ] - ---% Enumeration - -Enumeration(:"args") == - dom := GETREFV 9 - -- JHD added an extra slot to cache EQUAL methods - dom.0 := ["Enumeration", :args] - dom.1 := - [function lookupInTable,dom, - [["_=",[[["Boolean"],"_$","_$"],:12]], - ["coerce",[[$Expression,"_$"],:14], [["_$", $Symbol], :16]] - ]] - dom.2 := NIL - dom.3 := ["EnumerationCategory",:QCDR dom.0] - dom.4 := - [[ '(SetCategory) ],[ '(SetCategory) ]] - dom.5 := args - dom.6 := [function EnumEqual, :dom] - dom.7 := [function EnumPrint, :dom] - dom.8 := [function createEnum, :dom] - dom - -EnumEqual(e1,e2,dom) == e1=e2 -EnumPrint(enum, dom) == dom.5.enum -createEnum(sym, dom) == - args := dom.5 - val := -1 - for v in args for i in 0.. repeat - sym=v => return(val:=i) - val<0 => error ["Cannot coerce",sym,"to",["Enumeration",:args]] - val - ---% INSTANTIATORS - -RecordCategory(:"x") == constructorCategory ["Record",:x] - -EnumerationCategory(:"x") == constructorCategory ["Enumeration",:x] - -UnionCategory(:"x") == constructorCategory ["Union",:x] - ---ListCategory(:"x") == constructorCategory ("List",:x) - ---VectorCategory(:"x") == constructorCategory ("Vector",:x) - --above two now defined in SPAD code. - -constructorCategory (title is [op,:.]) == - constructorFunction:= GETL(op,"makeFunctionList") or - systemErrorHere '"constructorCategory" - [funlist,.]:= FUNCALL(constructorFunction,"$",title,$CategoryFrame) - oplist:= [[[a,b],true,c] for [a,b,c] in funlist] - cat:= - JoinInner([SetCategory(),mkCategory("domain",oplist,nil,nil,nil)], - $EmptyEnvironment) - cat.(0):= title - cat - ---mkMappingFunList(nam,mapForm,e) == [[],e] -mkMappingFunList(nam,mapForm,e) == - dc := GENSYM() - sigFunAlist:= - [["_=",[["Boolean"],nam ,nam],["ELT",dc,6]], - ["coerce",[$Expression,nam],["ELT",dc,7]]] - [substitute(nam,dc,substitute("$",'Rep,sigFunAlist)),e] - -mkRecordFunList(nam,["Record",:Alist],e) == - len:= #Alist - --- for (.,a,.) in Alist do --- if getmode(a,e) then MOAN("Symbol: ",a, --- " must not be both a variable and literal") --- e:= put(a,"isLiteral","true",e) - dc := GENSYM() - sigFunAlist:= - --:((a,(A,nam),("XLAM",("$1","$2"),("RECORDELT","$1",i,len))) - -- for i in 0..,(.,a,A) in Alist), - - [["construct",[nam,:[A for [.,a,A] in Alist]],"mkRecord"], - ["_=",[["Boolean"],nam ,nam],["ELT",dc,6]], - ["coerce",[$Expression,nam],["ELT",dc,7]],: - [["elt",[A,nam,PNAME a],["XLAM",["$1","$2"],["RECORDELT","$1",i,len]]] - for i in 0.. for [.,a,A] in Alist],: - [["setelt",[A,nam,PNAME a,A],["XLAM",["$1","$2","$3"], - ["SETRECORDELT","$1",i, len,"$3"]]] - for i in 0.. for [.,a,A] in Alist],: - [["copy",[nam,nam],["XLAM",["$1"],["RECORDCOPY", - "$1",len]]]]] - [substitute(nam,dc,substitute("$","Rep",sigFunAlist)),e] - -mkNewUnionFunList(name,form is ["Union",:listOfEntries],e) == - dc := name - if name = "Rep" then name := "$" - --2. create coercions from subtypes to subUnion - cList:= - [["_=",[["Boolean"],name ,name],["ELT",dc,6]], - ["coerce",[$Expression,name],["ELT",dc,7]],: - ("append"/ - [[["construct",[name,type],["XLAM",["#1"],["CONS",i,"#1"]]], - ["elt",[type,name,tag],cdownFun], - ["case",['(Boolean),name,tag], - ["XLAM",["#1"],["QEQCAR","#1",i]]]] - for [.,tag,type] in listOfEntries for i in 0..])] where - cdownFun() == - gg:=GENSYM() - $InteractiveMode => - ["XLAM",["#1"],["PROG1",["QCDR","#1"], - ["check_-union",["QEQCAR","#1",i],type,"#1"]]] - ["XLAM",["#1"],["PROG2",["LET",gg,"#1"],["QCDR",gg], - ["check_-union",["QEQCAR",gg,i],type,gg]]] - [cList,e] - -mkEnumerationFunList(nam,["Enumeration",:SL],e) == - len:= #SL - dc := nam - cList := - [nil, - ["_=",[["Boolean"],nam ,nam],["ELT",dc,6]], - ["_^_=",[["Boolean"],nam ,nam],["ELT",dc,7]], - ["coerce",[nam, ["Symbol"]], ["ELT", dc, 8]], - ["coerce",[["OutputForm"],nam],["ELT",dc, 9]]] - [substitute(nam, dc, cList),e] - -mkUnionFunList(op,form is ["Union",:listOfEntries],e) == - first listOfEntries is [":",.,.] => mkNewUnionFunList(op,form,e) - -- following call to order is a bug, but needs massive recomp to fix - listOfEntries:= orderUnionEntries listOfEntries - --1. create representations of subtypes - predList:= mkPredList listOfEntries - g:=GENSYM() - --2. create coercions from subtypes to subUnion - cList:= - [["_=",[["Boolean"],g ,g],["ELT",op,6]], - ["coerce",[$Expression,g],["ELT",op,7]],: - ("append"/ - [[["autoCoerce",[g,t],upFun], - ["coerce",[t,g],cdownFun], - ["autoCoerce",[t,g],downFun], --this should be removed eventually - ["case",['(Boolean),g,t],typeFun]] - for p in predList for t in listOfEntries])] where - upFun() == - p is ["EQCAR",x,n] => ["XLAM",["#1"],["CONS",n,"#1"]] - ["XLAM",["#1"],"#1"] - cdownFun() == - gg:=GENSYM() - if p is ["EQCAR",x,n] then - ref:=["QCDR",gg] - q:= ["QEQCAR", gg, n] - else - ref:=gg - q:= substitute(gg,"#1",p) - ["XLAM",["#1"],["PROG2",["LET",gg,"#1"],ref, - ["check_-union",q,t,gg]]] - downFun() == - p is ["EQCAR",x,.] => - ["XLAM",["#1"],["QCDR","#1"]] - ["XLAM",["#1"],"#1"] - typeFun() == - p is ["EQCAR",x,n] => - ["XLAM",["#1"],["QEQCAR",x,n]] - ["XLAM",["#1"],p] - op:= - op="Rep" => "$" - op - cList:= substitute(op,g,cList) - [cList,e] - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot new file mode 100644 index 00000000..8bb8927c --- /dev/null +++ b/src/interp/c-util.boot @@ -0,0 +1,715 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- 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. + + +import '"g-util" +)package "BOOT" + +--% Debugging Functions + +CONTINUE() == continue() +continue() == FIN comp($x,$m,$f) + +LEVEL(:l) == APPLY('level,l) +level(:l) == + null l => same() + l is [n] and INTEGERP n => displayComp ($level:= n) + SAY '"Correct format: (level n) where n is the level you want to go to" + +UP() == up() +up() == displayComp ($level:= $level-1) + +SAME() == same() +same() == displayComp $level + +DOWN() == down() +down() == displayComp ($level:= $level+1) + +displaySemanticErrors() == + n:= #($semanticErrorStack:= REMDUP $semanticErrorStack) + n=0 => nil + l:= NREVERSE $semanticErrorStack + $semanticErrorStack:= nil + sayBrightly bright '" Semantic Errors:" + displaySemanticError(l,CUROUTSTREAM) + sayBrightly '" " + displayWarnings() + +displaySemanticError(l,stream) == + for x in l for i in 1.. repeat + sayBrightly(['" [",i,'"] ",:first x],stream) + +displayWarnings() == + n:= #($warningStack:= REMDUP $warningStack) + n=0 => nil + sayBrightly bright '" Warnings:" + l := NREVERSE $warningStack + displayWarning(l,CUROUTSTREAM) + $warningStack:= nil + sayBrightly '" " + +displayWarning(l,stream) == + for x in l for i in 1.. repeat + sayBrightly(['" [",i,'"] ",:x],stream) + +displayComp level == + $bright:= " << " + $dim:= " >> " + if $insideCapsuleFunctionIfTrue=true then + sayBrightly ['"error in function",'%b,$op,'%d,'%l] + --mathprint removeZeroOne mkErrorExpr level + pp removeZeroOne mkErrorExpr level + sayBrightly ['"****** level",'%b,level,'%d,'" ******"] + [$x,$m,$f,$exitModeStack]:= ELEM($s,level) + ($X:=$x;$M:=$m;$F:=$f) + SAY("$x:= ",$x) + SAY("$m:= ",$m) + SAY "$f:=" + F_,PRINT_-ONE $f + nil + +mkErrorExpr level == + bracket ASSOCLEFT DROP(level-#$s,$s) where + bracket l == + #l<2 => l + l is [a,b] => + highlight(b,a) where + highlight(b,a) == + atom b => + substitute(var,b,a) where + var:= INTERN STRCONC(STRINGIMAGE $bright,STRINGIMAGE b,STRINGIMAGE $dim) + highlight1(b,a) where + highlight1(b,a) == + atom a => a + a is [ =b,:c] => [$bright,b,$dim,:c] + [highlight1(b,first a),:highlight1(b,rest a)] + substitute(bracket rest l,first rest l,first l) + +compAndTrace [x,m,e] == + SAY("tracing comp, compFormWithModemap of: ",x) + TRACE_,1(["comp","compFormWithModemap"],nil) + T:= comp(x,m,e) + UNTRACE_,1 "comp" + UNTRACE_,1 "compFormWithModemap" + T + +errorRef s == stackWarning ['%b,s,'%d,'"has no value"] + +unErrorRef s == unStackWarning ['%b,s,'%d,'"has no value"] + +--% ENVIRONMENT FUNCTIONS + +consProplistOf(var,proplist,prop,val) == + semchkProplist(var,proplist,prop,val) + $InteractiveMode and (u:= assoc(prop,proplist)) => + RPLACD(u,val) + proplist + [[prop,:val],:proplist] + +warnLiteral x == + stackSemanticError(['%b,x,'%d, + '"is BOTH a variable and a literal"],nil) + +intersectionEnvironment(e,e') == + ce:= makeCommonEnvironment(e,e') + ic:= intersectionContour(deltaContour(e,ce),deltaContour(e',ce)) + e'':= (ic => addContour(ic,ce); ce) + --$ie:= e'' this line is for debugging purposes only + +deltaContour([[c,:cl],:el],[[c',:cl'],:el']) == + ^el=el' => systemError '"deltaContour" --a cop out for now + eliminateDuplicatePropertyLists contourDifference(c,c') where + contourDifference(c,c') == [first x for x in tails c while (x^=c')] + eliminateDuplicatePropertyLists contour == + contour is [[x,:.],:contour'] => + LASSOC(x,contour') => + --save some CONSing if possible + [first contour,:DELLASOS(x,eliminateDuplicatePropertyLists contour')] + [first contour,:eliminateDuplicatePropertyLists contour'] + nil + +intersectionContour(c,c') == + $var: local + computeIntersection(c,c') where + computeIntersection(c,c') == + varlist:= REMDUP ASSOCLEFT c + varlist':= REMDUP ASSOCLEFT c' + interVars:= setIntersection(varlist,varlist') + unionVars:= setUnion(varlist,varlist') + diffVars:= setDifference(unionVars,interVars) + modeAssoc:= buildModeAssoc(diffVars,c,c') + [:modeAssoc,: + [[x,:proplist] + for [x,:y] in c | member(x,interVars) and + (proplist:= interProplist(y,LASSOC($var:= x,c')))]] + interProplist(p,p') == + --p is new proplist; p' is old one + [:modeCompare(p,p'),:[pair' for pair in p | (pair':= compare(pair,p'))]] + buildModeAssoc(varlist,c,c') == + [[x,:mp] for x in varlist | (mp:= modeCompare(LASSOC(x,c),LASSOC(x,c')))] + compare(pair is [prop,:val],p') == + --1. if the property-value pair are identical, accept it immediately + pair=(pair':= assoc(prop,p')) => pair + --2. if property="value" and modes are unifiable, give intersection + -- property="value" but value=genSomeVariable)() + (val':= KDR pair') and prop="value" and + (m:= unifiable(val.mode,val'.mode)) => ["value",genSomeVariable(),m,nil] + --this tells us that an undeclared variable received + --two different values but with identical modes + --3. property="mode" is covered by modeCompare + prop="mode" => nil + modeCompare(p,p') == + pair:= assoc("mode",p) => + pair':= assoc("mode",p') => + m'':= unifiable(rest pair,rest pair') => LIST ["mode",:m''] + stackSemanticError(['%b,$var,'%d,"has two modes: "],nil) + --stackWarning ("mode for",'%b,$var,'%d,"introduced conditionally") + LIST ["conditionalmode",:rest pair] + --LIST pair + --stackWarning ("mode for",'%b,$var,'%d,"introduced conditionally") + pair':= assoc("mode",p') => LIST ["conditionalmode",:rest pair'] + --LIST pair' + unifiable(m1,m2) == + m1=m2 => m1 + --we may need to add code to coerce up to tagged unions + --but this can not be done here, but should be done by compIf + m:= + m1 is ["Union",:.] => + m2 is ["Union",:.] => ["Union",:S_+(rest m1,rest m2)] + ["Union",:S_+(rest m1,[m2])] + m2 is ["Union",:.] => ["Union",:S_+(rest m2,[m1])] + ["Union",m1,m2] + for u in getDomainsInScope $e repeat + if u is ["Union",:u'] and (and/[member(v,u') for v in rest m]) then + return m + --this loop will return NIL if not satisfied + +addContour(c,E is [cur,:tail]) == + [NCONC(fn(c,E),cur),:tail] where + fn(c,e) == + for [x,:proplist] in c repeat + fn1(x,proplist,getProplist(x,e)) where + fn1(x,p,ee) == + for pv in p repeat fn3(x,pv,ee) where + fn3(x,pv,e) == + [p,:v]:=pv + if member(x,$getPutTrace) then + pp([x,"has",pv]) + if p="conditionalmode" then + RPLACA(pv,"mode") + --check for conflicts with earlier mode + if vv:=LASSOC("mode",e) then + if v ^=vv then + stackWarning ["The conditional modes ", + v," and ",vv," conflict"] + LIST c + +makeCommonEnvironment(e,e') == + interE makeSameLength(e,e') where --$ie:= + interE [e,e'] == + rest e=rest e' => [interLocalE makeSameLength(first e,first e'),:rest e] + interE [rest e,rest e'] + interLocalE [le,le'] == + rest le=rest le' => + [interC makeSameLength(first le,first le'),:rest le] + interLocalE [rest le,rest le'] + interC [c,c'] == + c=c' => c + interC [rest c,rest c'] + makeSameLength(x,y) == + fn(x,y,#x,#y) where + fn(x,y,nx,ny) == + nx>ny => fn(rest x,y,nx-1,ny) + nx fn(x,rest y,nx,ny-1) + [x,y] + +printEnv E == + for x in E for i in 1.. repeat + for y in x for j in 1.. repeat + SAY('"******CONTOUR ",j,'", LEVEL ",i,'":******") + for z in y repeat + TERPRI() + SAY("Properties Of: ",first z) + for u in rest z repeat + PRIN0 first u + printString ": " + PRETTYPRINT tran(rest u,first u) where + tran(val,prop) == + prop="value" => DROP(-1,val) + val + +prEnv E == + for x in E for i in 1.. repeat + for y in x for j in 1.. repeat + SAY('"******CONTOUR ",j,'", LEVEL ",i,'":******") + for z in y | not LASSOC("modemap",rest z) repeat + TERPRI() + SAY("Properties Of: ",first z) + for u in rest z repeat + PRIN0 first u + printString ": " + PRETTYPRINT tran(rest u,first u) where + tran(val,prop) == + prop="value" => DROP(-1,val) + val + +prModemaps E == + listOfOperatorsSeenSoFar:= nil + for x in E for i in 1.. repeat + for y in x for j in 1.. repeat + for z in y | null member(first z,listOfOperatorsSeenSoFar) and + (modemap:= LASSOC("modemap",rest z)) repeat + listOfOperatorsSeenSoFar:= [first z,:listOfOperatorsSeenSoFar] + TERPRI() + PRIN0 first z + printString ": " + PRETTYPRINT modemap + +prTriple T == + SAY '"Code:" + pp T.0 + SAY '"Mode:" + pp T.1 + +TrimCF() == + new:= nil + old:= CAAR $CategoryFrame + for u in old repeat + if not ASSQ(first u,new) then + uold:= rest u + unew:= nil + for v in uold repeat if not ASSQ(first v,unew) then unew:= [v,:unew] + new:= [[first u,:NREVERSE unew],:new] + $CategoryFrame:= [[NREVERSE new]] + nil + + +--% PREDICATES + + +isConstantId(name,e) == + IDENTP name => + pl:= getProplist(name,e) => + (LASSOC("value",pl) or LASSOC("mode",pl) => false; true) + true + false + +isFalse() == nil + +isFluid s == atom s and "$"=(PNAME s).(0) + +isFunction(x,e) == + get(x,"modemap",e) or GETL(x,"SPECIAL") or x="case" or getmode(x,e) is [ + "Mapping",:.] + +isLiteral(x,e) == get(x,"isLiteral",e) + +makeLiteral(x,e) == put(x,"isLiteral","true",e) + +isSomeDomainVariable s == + IDENTP s and #(x:= PNAME s)>2 and x.(0)="#" and x.(1)="#" + +isSubset(x,y,e) == + x="$" and y="Rep" or x=y or + LASSOC(opOf x,get(opOf y,"Subsets",e) or GETL(opOf y,"Subsets")) or + LASSOC(opOf x,get(opOf y,"SubDomain",e)) or + opOf(y)='Type or opOf(y)='Object + +isDomainInScope(domain,e) == + domainList:= getDomainsInScope e + atom domain => + MEMQ(domain,domainList) => true + not IDENTP domain or isSomeDomainVariable domain => true + false + (name:= first domain)="Category" => true + ASSQ(name,domainList) => true +-- null CDR domain or domainMember(domain,domainList) => true +-- false + isFunctor name => false + true --is not a functor + +isSymbol x == IDENTP x or x=nil + +isSimple x == + atom x or $InteractiveMode => true + x is [op,:argl] and + isSideEffectFree op and (and/[isSimple y for y in argl]) + +isSideEffectFree op == + member(op,$SideEffectFreeFunctionList) or op is ["elt",.,op'] and + isSideEffectFree op' + +isAlmostSimple x == + --returns ( . ) or nil + $assignmentList: local --$assigmentList is only used in this function + transform:= + fn x where + fn x == + atom x or null rest x => x + [op,y,:l]:= x + op="has" => x + op="is" => x + op="LET" => + IDENTP y => (setAssignment LIST x; y) + true => (setAssignment [["LET",g:= genVariable(),:l],["LET",y,g]]; g) + isSideEffectFree op => [op,:mapInto(rest x, function fn)] + true => $assignmentList:= "failed" + setAssignment x == + $assignmentList="failed" => nil + $assignmentList:= [:$assignmentList,:x] + $assignmentList="failed" => nil + wrapSEQExit [:$assignmentList,transform] + +incExitLevel u == + adjExitLevel(u,1,1) + u + +decExitLevel u == + (adjExitLevel(u,1,-1); removeExit0 u) where + removeExit0 x == + atom x => x + x is ["exit",0,u] => removeExit0 u + [removeExit0 first x,:removeExit0 rest x] + +adjExitLevel(x,seqnum,inc) == + atom x => x + x is [op,:l] and MEMQ(op,'(SEQ REPEAT COLLECT)) => + for u in l repeat adjExitLevel(u,seqnum+1,inc) + x is ["exit",n,u] => + (adjExitLevel(u,seqnum,inc); seqnum>n => x; rplac(CADR x,n+inc)) + x is [op,:l] => for u in l repeat adjExitLevel(u,seqnum,inc) + +wrapSEQExit l == + null rest l => first l + [:c,x]:= [incExitLevel u for u in l] + ["SEQ",:c,["exit",1,x]] + + +--% UTILITY FUNCTIONS + +--appendOver x == "append"/x + +removeEnv t == [t.expr,t.mode,$EmptyEnvironment] -- t is a triple + +-- This function seems no longer used +--ordinsert(x,l) == +-- null l => [x] +-- x=first l => l +-- _?ORDER(x,first l) => [x,:l] +-- [first l,:ordinsert(x,rest l)] + +makeNonAtomic x == + atom x => [x] + x + +flatten(l,key) == + null l => nil + first l is [k,:r] and k=key => [:r,:flatten(rest l,key)] + [first l,:flatten(rest l,key)] + +genDomainVar() == + $Index:= $Index+1 + INTERNL STRCONC("#D",STRINGIMAGE $Index) + +genVariable() == + INTERNL STRCONC("#G",STRINGIMAGE ($genSDVar:= $genSDVar+1)) + +genSomeVariable() == + INTERNL STRCONC("##",STRINGIMAGE ($genSDVar:= $genSDVar+1)) + +listOfIdentifiersIn x == + IDENTP x => [x] + x is [op,:l] => REMDUP ("append"/[listOfIdentifiersIn y for y in l]) + nil + +mapInto(x,fn) == [FUNCALL(fn,y) for y in x] + +numOfOccurencesOf(x,y) == + fn(x,y,0) where + fn(x,y,n) == + null y => 0 + x=y => n+1 + atom y => n + fn(x,first y,n)+fn(x,rest y,n) + +compilerMessage x == + $PrintCompilerMessageIfTrue => APPLX("SAY",x) + +printDashedLine() == + SAY + '"--------------------------------------------------------------------------" + +stackSemanticError(msg,expr) == + BUMPERRORCOUNT "semantic" + if $insideCapsuleFunctionIfTrue then msg:= [$op,": ",:msg] + if atom msg then msg:= LIST msg + entry:= [msg,expr] + if not member(entry,$semanticErrorStack) then $semanticErrorStack:= + [entry,:$semanticErrorStack] + $scanIfTrue and $insideCapsuleFunctionIfTrue=true and #$semanticErrorStack- + $initCapsuleErrorCount>3 => THROW("compCapsuleBody",nil) + nil + +stackWarning msg == + if $insideCapsuleFunctionIfTrue then msg:= [$op,": ",:msg] + if not member(msg,$warningStack) then $warningStack:= [msg,:$warningStack] + nil + +unStackWarning msg == + if $insideCapsuleFunctionIfTrue then msg:= [$op,": ",:msg] + $warningStack:= EFFACE(msg,$warningStack) + nil + +stackMessage msg == + $compErrorMessageStack:= [msg,:$compErrorMessageStack] + nil + +stackMessageIfNone msg == + --used in situations such as compForm where the earliest message is wanted + if null $compErrorMessageStack then $compErrorMessageStack:= + [msg,:$compErrorMessageStack] + nil + +stackAndThrow msg == + $compErrorMessageStack:= [msg,:$compErrorMessageStack] + THROW("compOrCroak",nil) + +printString x == PRINTEXP (STRINGP x => x; PNAME x) + +printAny x == if atom x then printString x else PRIN0 x + +printSignature(before,op,[target,:argSigList]) == + printString before + printString op + printString ": _(" + if argSigList then + printAny first argSigList + for m in rest argSigList repeat (printString ","; printAny m) + printString "_) -> " + printAny target + TERPRI() + +pmatch(s,p) == pmatchWithSl(s,p,"ok") + +pmatchWithSl(s,p,al) == + s=$EmptyMode => nil + s=p => al + v:= assoc(p,al) => s=rest v or al + MEMQ(p,$PatternVariableList) => [[p,:s],:al] + null atom p and null atom s and (al':= pmatchWithSl(first s,first p,al)) and + pmatchWithSl(rest s,rest p,al') + +elapsedTime() == + currentTime:= TEMPUS_-FUGIT() + elapsedSeconds:= (currentTime-$previousTime)*1.0/$timerTicksPerSecond + $previousTime:= currentTime + elapsedSeconds + +addStats([a,b],[c,d]) == [a+c,b+d] + +printStats [byteCount,elapsedSeconds] == + timeString := normalizeStatAndStringify elapsedSeconds + if byteCount = 0 then SAY('"Time: ",timeString,'" SEC.") else + SAY('"Size: ",byteCount,'" BYTES Time: ",timeString,'" SEC.") + TERPRI() + nil + +extendsCategoryForm(domain,form,form') == + --is domain of category form also of category form'? + --domain is only used for SubsetCategory resolution. + --and ensuring that X being a Ring means that it + --satisfies (Algebra X) + form=form' => true + form=$Category => nil + form' is ["Join",:l] => and/[extendsCategoryForm(domain,form,x) for x in l] + form' is ["CATEGORY",.,:l] => + and/[extendsCategoryForm(domain,form,x) for x in l] + form' is ["SubsetCategory",cat,dom] => + extendsCategoryForm(domain,form,cat) and isSubset(domain,dom,$e) + form is ["Join",:l] => or/[extendsCategoryForm(domain,x,form') for x in l] + form is ["CATEGORY",.,:l] => + member(form',l) or + stackWarning ["not known that ",form'," is of mode ",form] or true + isCategoryForm(form,$EmptyEnvironment) => + --Constructs the associated vector + formVec:=(compMakeCategoryObject(form,$e)).expr + --Must be $e to pick up locally bound domains + form' is ["SIGNATURE",op,args,:.] => + assoc([op,args],formVec.(1)) or + assoc(SUBSTQ(domain,"$",[op,args]), + SUBSTQ(domain,"$",formVec.(1))) + form' is ["ATTRIBUTE",at] => + assoc(at,formVec.2) or + assoc(SUBSTQ(domain,"$",at),SUBSTQ(domain,"$",formVec.2)) + form' is ["IF",:.] => true --temporary hack so comp won't fail + -- Are we dealing with an Aldor category? If so use the "has" function ... + # formVec = 1 => newHasTest(form,form') + catvlist:= formVec.4 + member(form',first catvlist) or + member(form',SUBSTQ(domain,"$",first catvlist)) or + (or/ + [extendsCategoryForm(domain,SUBSTQ(domain,"$",cat),form') + for [cat,:.] in CADR catvlist]) + nil + +getmode(x,e) == + prop:=getProplist(x,e) + u:= LASSQ("value",prop) => u.mode + LASSQ("mode",prop) + +getmodeOrMapping(x,e) == + u:= getmode(x,e) => u + (u:= get(x,"modemap",e)) is [[[.,:map],.],:.] => ["Mapping",:map] + nil + +outerProduct l == + --of a list of lists + null l => LIST nil + "append"/[[[x,:y] for y in outerProduct rest l] for x in first l] + +sublisR(al,u) == + atom u => u + y:= rassoc(t:= [sublisR(al,x) for x in u],al) => y + true => t + +substituteOp(op',op,x) == + atom x => x + [(op=(f:= first x) => op'; f),:[substituteOp(op',op,y) for y in rest x]] + +--substituteForFormalArguments(argl,expr) == +-- SUBLIS([[v,:a] for a in argl for v in $FormalMapVariableList],expr) + + -- following is only intended for substituting in domains slots 1 and 4 + -- signatures and categories +sublisV(p,e) == + (atom p => e; suba(p,e)) where + suba(p,e) == + STRINGP e => e + -- no need to descend vectors unless they are categories + --REFVECP e => LIST2REFVEC [suba(p,e.i) for i in 0..MAXINDEX e] + isCategory e => LIST2REFVEC [suba(p,e.i) for i in 0..MAXINDEX e] + atom e => (y:= ASSQ(e,p) => rest y; e) + u:= suba(p,QCAR e) + v:= suba(p,QCDR e) + EQ(QCAR e,u) and EQ(QCDR e,v) => e + [u,:v] + +--% DEBUGGING PRINT ROUTINES used in breaks + +_?MODEMAPS x == _?modemaps x +_?modemaps x == + env:= + $insideCapsuleFunctionIfTrue=true => $CapsuleModemapFrame + $f + x="all" => displayModemaps env + -- displayOpModemaps(x,old2NewModemaps get(x,"modemap",env)) + displayOpModemaps(x,get(x,"modemap",env)) + + +old2NewModemaps x == +-- [[dcSig,pred] for [dcSig,[pred,:.],:.] in x] + x is [dcSig,[pred,:.],:.] => [dcSig,pred] + x + +traceUp() == + atom $x => sayBrightly "$x is an atom" + for y in rest $x repeat + u:= comp(y,$EmptyMode,$f) => + sayBrightly [y,'" ==> mode",'%b,u.mode,'%d] + sayBrightly [y,'" does not compile"] + +_?M x == _?m x +_?m x == + u:= comp(x,$EmptyMode,$f) => u.mode + nil + +traceDown() == + mmList:= getFormModemaps($x,$f) => + for mm in mmList repeat if u:= qModemap mm then return u + sayBrightly "no modemaps for $x" + +qModemap mm == + sayBrightly ['%b,"modemap",'%d,:formatModemap mm] + [[dc,target,:sl],[pred,:.]]:= mm + and/[qArg(a,m) for a in rest $x for m in sl] => target + sayBrightly ['%b,"fails",'%d,'%l] + +qArg(a,m) == + yesOrNo:= + u:= comp(a,m,$f) => "yes" + "no" + sayBrightly [a," --> ",m,'%b,yesOrNo,'%d] + yesOrNo="yes" + +_?COMP x == _?comp x +_?comp x == + msg:= + u:= comp(x,$EmptyMode,$f) => + [MAKESTRING "compiles to mode",'%b,u.mode,'%d] + nil + sayBrightly msg + +_?domains() == pp getDomainsInScope $f +_?DOMAINS() == ?domains() + +_?mode x == displayProplist(x,[["mode",:getmode(x,$f)]]) +_?MODE x == _?mode x + +_?properties x == displayProplist(x,getProplist(x,$f)) +_?PROPERTIES x == _?properties x + +_?value x == displayProplist(x,[["value",:get(x,"value",$f)]]) +_?VALUE x == _?value x + +displayProplist(x,alist) == + sayBrightly ["properties of",'%b,x,'%d,":"] + fn alist where + fn alist == + alist is [[prop,:val],:l] => + if prop="value" then val:= [val.expr,val.mode,'"..."] + sayBrightly [" ",'%b,prop,'%d,": ",val] + fn deleteAssoc(prop,l) + +displayModemaps E == + listOfOperatorsSeenSoFar:= nil + for x in E for i in 1.. repeat + for y in x for j in 1.. repeat + for z in y | null member(first z,listOfOperatorsSeenSoFar) and + (modemaps:= LASSOC("modemap",rest z)) repeat + listOfOperatorsSeenSoFar:= [first z,:listOfOperatorsSeenSoFar] + displayOpModemaps(first z,modemaps) + +--% General object traversal functions + +GCOPY ob == COPY ob -- for now + diff --git a/src/interp/c-util.boot.pamphlet b/src/interp/c-util.boot.pamphlet deleted file mode 100644 index 6bc3f726..00000000 --- a/src/interp/c-util.boot.pamphlet +++ /dev/null @@ -1,740 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/c-util.boot} Pamphlet} -\author{The Axiom Team} - -\begin{document} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\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. - -@ -<<*>>= -<> - -import '"g-util" -)package "BOOT" - ---% Debugging Functions - -CONTINUE() == continue() -continue() == FIN comp($x,$m,$f) - -LEVEL(:l) == APPLY('level,l) -level(:l) == - null l => same() - l is [n] and INTEGERP n => displayComp ($level:= n) - SAY '"Correct format: (level n) where n is the level you want to go to" - -UP() == up() -up() == displayComp ($level:= $level-1) - -SAME() == same() -same() == displayComp $level - -DOWN() == down() -down() == displayComp ($level:= $level+1) - -displaySemanticErrors() == - n:= #($semanticErrorStack:= REMDUP $semanticErrorStack) - n=0 => nil - l:= NREVERSE $semanticErrorStack - $semanticErrorStack:= nil - sayBrightly bright '" Semantic Errors:" - displaySemanticError(l,CUROUTSTREAM) - sayBrightly '" " - displayWarnings() - -displaySemanticError(l,stream) == - for x in l for i in 1.. repeat - sayBrightly(['" [",i,'"] ",:first x],stream) - -displayWarnings() == - n:= #($warningStack:= REMDUP $warningStack) - n=0 => nil - sayBrightly bright '" Warnings:" - l := NREVERSE $warningStack - displayWarning(l,CUROUTSTREAM) - $warningStack:= nil - sayBrightly '" " - -displayWarning(l,stream) == - for x in l for i in 1.. repeat - sayBrightly(['" [",i,'"] ",:x],stream) - -displayComp level == - $bright:= " << " - $dim:= " >> " - if $insideCapsuleFunctionIfTrue=true then - sayBrightly ['"error in function",'%b,$op,'%d,'%l] - --mathprint removeZeroOne mkErrorExpr level - pp removeZeroOne mkErrorExpr level - sayBrightly ['"****** level",'%b,level,'%d,'" ******"] - [$x,$m,$f,$exitModeStack]:= ELEM($s,level) - ($X:=$x;$M:=$m;$F:=$f) - SAY("$x:= ",$x) - SAY("$m:= ",$m) - SAY "$f:=" - F_,PRINT_-ONE $f - nil - -mkErrorExpr level == - bracket ASSOCLEFT DROP(level-#$s,$s) where - bracket l == - #l<2 => l - l is [a,b] => - highlight(b,a) where - highlight(b,a) == - atom b => - substitute(var,b,a) where - var:= INTERN STRCONC(STRINGIMAGE $bright,STRINGIMAGE b,STRINGIMAGE $dim) - highlight1(b,a) where - highlight1(b,a) == - atom a => a - a is [ =b,:c] => [$bright,b,$dim,:c] - [highlight1(b,first a),:highlight1(b,rest a)] - substitute(bracket rest l,first rest l,first l) - -compAndTrace [x,m,e] == - SAY("tracing comp, compFormWithModemap of: ",x) - TRACE_,1(["comp","compFormWithModemap"],nil) - T:= comp(x,m,e) - UNTRACE_,1 "comp" - UNTRACE_,1 "compFormWithModemap" - T - -errorRef s == stackWarning ['%b,s,'%d,'"has no value"] - -unErrorRef s == unStackWarning ['%b,s,'%d,'"has no value"] - ---% ENVIRONMENT FUNCTIONS - -consProplistOf(var,proplist,prop,val) == - semchkProplist(var,proplist,prop,val) - $InteractiveMode and (u:= assoc(prop,proplist)) => - RPLACD(u,val) - proplist - [[prop,:val],:proplist] - -warnLiteral x == - stackSemanticError(['%b,x,'%d, - '"is BOTH a variable and a literal"],nil) - -intersectionEnvironment(e,e') == - ce:= makeCommonEnvironment(e,e') - ic:= intersectionContour(deltaContour(e,ce),deltaContour(e',ce)) - e'':= (ic => addContour(ic,ce); ce) - --$ie:= e'' this line is for debugging purposes only - -deltaContour([[c,:cl],:el],[[c',:cl'],:el']) == - ^el=el' => systemError '"deltaContour" --a cop out for now - eliminateDuplicatePropertyLists contourDifference(c,c') where - contourDifference(c,c') == [first x for x in tails c while (x^=c')] - eliminateDuplicatePropertyLists contour == - contour is [[x,:.],:contour'] => - LASSOC(x,contour') => - --save some CONSing if possible - [first contour,:DELLASOS(x,eliminateDuplicatePropertyLists contour')] - [first contour,:eliminateDuplicatePropertyLists contour'] - nil - -intersectionContour(c,c') == - $var: local - computeIntersection(c,c') where - computeIntersection(c,c') == - varlist:= REMDUP ASSOCLEFT c - varlist':= REMDUP ASSOCLEFT c' - interVars:= setIntersection(varlist,varlist') - unionVars:= setUnion(varlist,varlist') - diffVars:= setDifference(unionVars,interVars) - modeAssoc:= buildModeAssoc(diffVars,c,c') - [:modeAssoc,: - [[x,:proplist] - for [x,:y] in c | member(x,interVars) and - (proplist:= interProplist(y,LASSOC($var:= x,c')))]] - interProplist(p,p') == - --p is new proplist; p' is old one - [:modeCompare(p,p'),:[pair' for pair in p | (pair':= compare(pair,p'))]] - buildModeAssoc(varlist,c,c') == - [[x,:mp] for x in varlist | (mp:= modeCompare(LASSOC(x,c),LASSOC(x,c')))] - compare(pair is [prop,:val],p') == - --1. if the property-value pair are identical, accept it immediately - pair=(pair':= assoc(prop,p')) => pair - --2. if property="value" and modes are unifiable, give intersection - -- property="value" but value=genSomeVariable)() - (val':= KDR pair') and prop="value" and - (m:= unifiable(val.mode,val'.mode)) => ["value",genSomeVariable(),m,nil] - --this tells us that an undeclared variable received - --two different values but with identical modes - --3. property="mode" is covered by modeCompare - prop="mode" => nil - modeCompare(p,p') == - pair:= assoc("mode",p) => - pair':= assoc("mode",p') => - m'':= unifiable(rest pair,rest pair') => LIST ["mode",:m''] - stackSemanticError(['%b,$var,'%d,"has two modes: "],nil) - --stackWarning ("mode for",'%b,$var,'%d,"introduced conditionally") - LIST ["conditionalmode",:rest pair] - --LIST pair - --stackWarning ("mode for",'%b,$var,'%d,"introduced conditionally") - pair':= assoc("mode",p') => LIST ["conditionalmode",:rest pair'] - --LIST pair' - unifiable(m1,m2) == - m1=m2 => m1 - --we may need to add code to coerce up to tagged unions - --but this can not be done here, but should be done by compIf - m:= - m1 is ["Union",:.] => - m2 is ["Union",:.] => ["Union",:S_+(rest m1,rest m2)] - ["Union",:S_+(rest m1,[m2])] - m2 is ["Union",:.] => ["Union",:S_+(rest m2,[m1])] - ["Union",m1,m2] - for u in getDomainsInScope $e repeat - if u is ["Union",:u'] and (and/[member(v,u') for v in rest m]) then - return m - --this loop will return NIL if not satisfied - -addContour(c,E is [cur,:tail]) == - [NCONC(fn(c,E),cur),:tail] where - fn(c,e) == - for [x,:proplist] in c repeat - fn1(x,proplist,getProplist(x,e)) where - fn1(x,p,ee) == - for pv in p repeat fn3(x,pv,ee) where - fn3(x,pv,e) == - [p,:v]:=pv - if member(x,$getPutTrace) then - pp([x,"has",pv]) - if p="conditionalmode" then - RPLACA(pv,"mode") - --check for conflicts with earlier mode - if vv:=LASSOC("mode",e) then - if v ^=vv then - stackWarning ["The conditional modes ", - v," and ",vv," conflict"] - LIST c - -makeCommonEnvironment(e,e') == - interE makeSameLength(e,e') where --$ie:= - interE [e,e'] == - rest e=rest e' => [interLocalE makeSameLength(first e,first e'),:rest e] - interE [rest e,rest e'] - interLocalE [le,le'] == - rest le=rest le' => - [interC makeSameLength(first le,first le'),:rest le] - interLocalE [rest le,rest le'] - interC [c,c'] == - c=c' => c - interC [rest c,rest c'] - makeSameLength(x,y) == - fn(x,y,#x,#y) where - fn(x,y,nx,ny) == - nx>ny => fn(rest x,y,nx-1,ny) - nx fn(x,rest y,nx,ny-1) - [x,y] - -printEnv E == - for x in E for i in 1.. repeat - for y in x for j in 1.. repeat - SAY('"******CONTOUR ",j,'", LEVEL ",i,'":******") - for z in y repeat - TERPRI() - SAY("Properties Of: ",first z) - for u in rest z repeat - PRIN0 first u - printString ": " - PRETTYPRINT tran(rest u,first u) where - tran(val,prop) == - prop="value" => DROP(-1,val) - val - -prEnv E == - for x in E for i in 1.. repeat - for y in x for j in 1.. repeat - SAY('"******CONTOUR ",j,'", LEVEL ",i,'":******") - for z in y | not LASSOC("modemap",rest z) repeat - TERPRI() - SAY("Properties Of: ",first z) - for u in rest z repeat - PRIN0 first u - printString ": " - PRETTYPRINT tran(rest u,first u) where - tran(val,prop) == - prop="value" => DROP(-1,val) - val - -prModemaps E == - listOfOperatorsSeenSoFar:= nil - for x in E for i in 1.. repeat - for y in x for j in 1.. repeat - for z in y | null member(first z,listOfOperatorsSeenSoFar) and - (modemap:= LASSOC("modemap",rest z)) repeat - listOfOperatorsSeenSoFar:= [first z,:listOfOperatorsSeenSoFar] - TERPRI() - PRIN0 first z - printString ": " - PRETTYPRINT modemap - -prTriple T == - SAY '"Code:" - pp T.0 - SAY '"Mode:" - pp T.1 - -TrimCF() == - new:= nil - old:= CAAR $CategoryFrame - for u in old repeat - if not ASSQ(first u,new) then - uold:= rest u - unew:= nil - for v in uold repeat if not ASSQ(first v,unew) then unew:= [v,:unew] - new:= [[first u,:NREVERSE unew],:new] - $CategoryFrame:= [[NREVERSE new]] - nil - - ---% PREDICATES - - -isConstantId(name,e) == - IDENTP name => - pl:= getProplist(name,e) => - (LASSOC("value",pl) or LASSOC("mode",pl) => false; true) - true - false - -isFalse() == nil - -isFluid s == atom s and "$"=(PNAME s).(0) - -isFunction(x,e) == - get(x,"modemap",e) or GETL(x,"SPECIAL") or x="case" or getmode(x,e) is [ - "Mapping",:.] - -isLiteral(x,e) == get(x,"isLiteral",e) - -makeLiteral(x,e) == put(x,"isLiteral","true",e) - -isSomeDomainVariable s == - IDENTP s and #(x:= PNAME s)>2 and x.(0)="#" and x.(1)="#" - -isSubset(x,y,e) == - x="$" and y="Rep" or x=y or - LASSOC(opOf x,get(opOf y,"Subsets",e) or GETL(opOf y,"Subsets")) or - LASSOC(opOf x,get(opOf y,"SubDomain",e)) or - opOf(y)='Type or opOf(y)='Object - -isDomainInScope(domain,e) == - domainList:= getDomainsInScope e - atom domain => - MEMQ(domain,domainList) => true - not IDENTP domain or isSomeDomainVariable domain => true - false - (name:= first domain)="Category" => true - ASSQ(name,domainList) => true --- null CDR domain or domainMember(domain,domainList) => true --- false - isFunctor name => false - true --is not a functor - -isSymbol x == IDENTP x or x=nil - -isSimple x == - atom x or $InteractiveMode => true - x is [op,:argl] and - isSideEffectFree op and (and/[isSimple y for y in argl]) - -isSideEffectFree op == - member(op,$SideEffectFreeFunctionList) or op is ["elt",.,op'] and - isSideEffectFree op' - -isAlmostSimple x == - --returns ( . ) or nil - $assignmentList: local --$assigmentList is only used in this function - transform:= - fn x where - fn x == - atom x or null rest x => x - [op,y,:l]:= x - op="has" => x - op="is" => x - op="LET" => - IDENTP y => (setAssignment LIST x; y) - true => (setAssignment [["LET",g:= genVariable(),:l],["LET",y,g]]; g) - isSideEffectFree op => [op,:mapInto(rest x, function fn)] - true => $assignmentList:= "failed" - setAssignment x == - $assignmentList="failed" => nil - $assignmentList:= [:$assignmentList,:x] - $assignmentList="failed" => nil - wrapSEQExit [:$assignmentList,transform] - -incExitLevel u == - adjExitLevel(u,1,1) - u - -decExitLevel u == - (adjExitLevel(u,1,-1); removeExit0 u) where - removeExit0 x == - atom x => x - x is ["exit",0,u] => removeExit0 u - [removeExit0 first x,:removeExit0 rest x] - -adjExitLevel(x,seqnum,inc) == - atom x => x - x is [op,:l] and MEMQ(op,'(SEQ REPEAT COLLECT)) => - for u in l repeat adjExitLevel(u,seqnum+1,inc) - x is ["exit",n,u] => - (adjExitLevel(u,seqnum,inc); seqnum>n => x; rplac(CADR x,n+inc)) - x is [op,:l] => for u in l repeat adjExitLevel(u,seqnum,inc) - -wrapSEQExit l == - null rest l => first l - [:c,x]:= [incExitLevel u for u in l] - ["SEQ",:c,["exit",1,x]] - - ---% UTILITY FUNCTIONS - ---appendOver x == "append"/x - -removeEnv t == [t.expr,t.mode,$EmptyEnvironment] -- t is a triple - --- This function seems no longer used ---ordinsert(x,l) == --- null l => [x] --- x=first l => l --- _?ORDER(x,first l) => [x,:l] --- [first l,:ordinsert(x,rest l)] - -makeNonAtomic x == - atom x => [x] - x - -flatten(l,key) == - null l => nil - first l is [k,:r] and k=key => [:r,:flatten(rest l,key)] - [first l,:flatten(rest l,key)] - -genDomainVar() == - $Index:= $Index+1 - INTERNL STRCONC("#D",STRINGIMAGE $Index) - -genVariable() == - INTERNL STRCONC("#G",STRINGIMAGE ($genSDVar:= $genSDVar+1)) - -genSomeVariable() == - INTERNL STRCONC("##",STRINGIMAGE ($genSDVar:= $genSDVar+1)) - -listOfIdentifiersIn x == - IDENTP x => [x] - x is [op,:l] => REMDUP ("append"/[listOfIdentifiersIn y for y in l]) - nil - -mapInto(x,fn) == [FUNCALL(fn,y) for y in x] - -numOfOccurencesOf(x,y) == - fn(x,y,0) where - fn(x,y,n) == - null y => 0 - x=y => n+1 - atom y => n - fn(x,first y,n)+fn(x,rest y,n) - -compilerMessage x == - $PrintCompilerMessageIfTrue => APPLX("SAY",x) - -printDashedLine() == - SAY - '"--------------------------------------------------------------------------" - -stackSemanticError(msg,expr) == - BUMPERRORCOUNT "semantic" - if $insideCapsuleFunctionIfTrue then msg:= [$op,": ",:msg] - if atom msg then msg:= LIST msg - entry:= [msg,expr] - if not member(entry,$semanticErrorStack) then $semanticErrorStack:= - [entry,:$semanticErrorStack] - $scanIfTrue and $insideCapsuleFunctionIfTrue=true and #$semanticErrorStack- - $initCapsuleErrorCount>3 => THROW("compCapsuleBody",nil) - nil - -stackWarning msg == - if $insideCapsuleFunctionIfTrue then msg:= [$op,": ",:msg] - if not member(msg,$warningStack) then $warningStack:= [msg,:$warningStack] - nil - -unStackWarning msg == - if $insideCapsuleFunctionIfTrue then msg:= [$op,": ",:msg] - $warningStack:= EFFACE(msg,$warningStack) - nil - -stackMessage msg == - $compErrorMessageStack:= [msg,:$compErrorMessageStack] - nil - -stackMessageIfNone msg == - --used in situations such as compForm where the earliest message is wanted - if null $compErrorMessageStack then $compErrorMessageStack:= - [msg,:$compErrorMessageStack] - nil - -stackAndThrow msg == - $compErrorMessageStack:= [msg,:$compErrorMessageStack] - THROW("compOrCroak",nil) - -printString x == PRINTEXP (STRINGP x => x; PNAME x) - -printAny x == if atom x then printString x else PRIN0 x - -printSignature(before,op,[target,:argSigList]) == - printString before - printString op - printString ": _(" - if argSigList then - printAny first argSigList - for m in rest argSigList repeat (printString ","; printAny m) - printString "_) -> " - printAny target - TERPRI() - -pmatch(s,p) == pmatchWithSl(s,p,"ok") - -pmatchWithSl(s,p,al) == - s=$EmptyMode => nil - s=p => al - v:= assoc(p,al) => s=rest v or al - MEMQ(p,$PatternVariableList) => [[p,:s],:al] - null atom p and null atom s and (al':= pmatchWithSl(first s,first p,al)) and - pmatchWithSl(rest s,rest p,al') - -elapsedTime() == - currentTime:= TEMPUS_-FUGIT() - elapsedSeconds:= (currentTime-$previousTime)*1.0/$timerTicksPerSecond - $previousTime:= currentTime - elapsedSeconds - -addStats([a,b],[c,d]) == [a+c,b+d] - -printStats [byteCount,elapsedSeconds] == - timeString := normalizeStatAndStringify elapsedSeconds - if byteCount = 0 then SAY('"Time: ",timeString,'" SEC.") else - SAY('"Size: ",byteCount,'" BYTES Time: ",timeString,'" SEC.") - TERPRI() - nil - -extendsCategoryForm(domain,form,form') == - --is domain of category form also of category form'? - --domain is only used for SubsetCategory resolution. - --and ensuring that X being a Ring means that it - --satisfies (Algebra X) - form=form' => true - form=$Category => nil - form' is ["Join",:l] => and/[extendsCategoryForm(domain,form,x) for x in l] - form' is ["CATEGORY",.,:l] => - and/[extendsCategoryForm(domain,form,x) for x in l] - form' is ["SubsetCategory",cat,dom] => - extendsCategoryForm(domain,form,cat) and isSubset(domain,dom,$e) - form is ["Join",:l] => or/[extendsCategoryForm(domain,x,form') for x in l] - form is ["CATEGORY",.,:l] => - member(form',l) or - stackWarning ["not known that ",form'," is of mode ",form] or true - isCategoryForm(form,$EmptyEnvironment) => - --Constructs the associated vector - formVec:=(compMakeCategoryObject(form,$e)).expr - --Must be $e to pick up locally bound domains - form' is ["SIGNATURE",op,args,:.] => - assoc([op,args],formVec.(1)) or - assoc(SUBSTQ(domain,"$",[op,args]), - SUBSTQ(domain,"$",formVec.(1))) - form' is ["ATTRIBUTE",at] => - assoc(at,formVec.2) or - assoc(SUBSTQ(domain,"$",at),SUBSTQ(domain,"$",formVec.2)) - form' is ["IF",:.] => true --temporary hack so comp won't fail - -- Are we dealing with an Aldor category? If so use the "has" function ... - # formVec = 1 => newHasTest(form,form') - catvlist:= formVec.4 - member(form',first catvlist) or - member(form',SUBSTQ(domain,"$",first catvlist)) or - (or/ - [extendsCategoryForm(domain,SUBSTQ(domain,"$",cat),form') - for [cat,:.] in CADR catvlist]) - nil - -getmode(x,e) == - prop:=getProplist(x,e) - u:= LASSQ("value",prop) => u.mode - LASSQ("mode",prop) - -getmodeOrMapping(x,e) == - u:= getmode(x,e) => u - (u:= get(x,"modemap",e)) is [[[.,:map],.],:.] => ["Mapping",:map] - nil - -outerProduct l == - --of a list of lists - null l => LIST nil - "append"/[[[x,:y] for y in outerProduct rest l] for x in first l] - -sublisR(al,u) == - atom u => u - y:= rassoc(t:= [sublisR(al,x) for x in u],al) => y - true => t - -substituteOp(op',op,x) == - atom x => x - [(op=(f:= first x) => op'; f),:[substituteOp(op',op,y) for y in rest x]] - ---substituteForFormalArguments(argl,expr) == --- SUBLIS([[v,:a] for a in argl for v in $FormalMapVariableList],expr) - - -- following is only intended for substituting in domains slots 1 and 4 - -- signatures and categories -sublisV(p,e) == - (atom p => e; suba(p,e)) where - suba(p,e) == - STRINGP e => e - -- no need to descend vectors unless they are categories - --REFVECP e => LIST2REFVEC [suba(p,e.i) for i in 0..MAXINDEX e] - isCategory e => LIST2REFVEC [suba(p,e.i) for i in 0..MAXINDEX e] - atom e => (y:= ASSQ(e,p) => rest y; e) - u:= suba(p,QCAR e) - v:= suba(p,QCDR e) - EQ(QCAR e,u) and EQ(QCDR e,v) => e - [u,:v] - ---% DEBUGGING PRINT ROUTINES used in breaks - -_?MODEMAPS x == _?modemaps x -_?modemaps x == - env:= - $insideCapsuleFunctionIfTrue=true => $CapsuleModemapFrame - $f - x="all" => displayModemaps env - -- displayOpModemaps(x,old2NewModemaps get(x,"modemap",env)) - displayOpModemaps(x,get(x,"modemap",env)) - - -old2NewModemaps x == --- [[dcSig,pred] for [dcSig,[pred,:.],:.] in x] - x is [dcSig,[pred,:.],:.] => [dcSig,pred] - x - -traceUp() == - atom $x => sayBrightly "$x is an atom" - for y in rest $x repeat - u:= comp(y,$EmptyMode,$f) => - sayBrightly [y,'" ==> mode",'%b,u.mode,'%d] - sayBrightly [y,'" does not compile"] - -_?M x == _?m x -_?m x == - u:= comp(x,$EmptyMode,$f) => u.mode - nil - -traceDown() == - mmList:= getFormModemaps($x,$f) => - for mm in mmList repeat if u:= qModemap mm then return u - sayBrightly "no modemaps for $x" - -qModemap mm == - sayBrightly ['%b,"modemap",'%d,:formatModemap mm] - [[dc,target,:sl],[pred,:.]]:= mm - and/[qArg(a,m) for a in rest $x for m in sl] => target - sayBrightly ['%b,"fails",'%d,'%l] - -qArg(a,m) == - yesOrNo:= - u:= comp(a,m,$f) => "yes" - "no" - sayBrightly [a," --> ",m,'%b,yesOrNo,'%d] - yesOrNo="yes" - -_?COMP x == _?comp x -_?comp x == - msg:= - u:= comp(x,$EmptyMode,$f) => - [MAKESTRING "compiles to mode",'%b,u.mode,'%d] - nil - sayBrightly msg - -_?domains() == pp getDomainsInScope $f -_?DOMAINS() == ?domains() - -_?mode x == displayProplist(x,[["mode",:getmode(x,$f)]]) -_?MODE x == _?mode x - -_?properties x == displayProplist(x,getProplist(x,$f)) -_?PROPERTIES x == _?properties x - -_?value x == displayProplist(x,[["value",:get(x,"value",$f)]]) -_?VALUE x == _?value x - -displayProplist(x,alist) == - sayBrightly ["properties of",'%b,x,'%d,":"] - fn alist where - fn alist == - alist is [[prop,:val],:l] => - if prop="value" then val:= [val.expr,val.mode,'"..."] - sayBrightly [" ",'%b,prop,'%d,": ",val] - fn deleteAssoc(prop,l) - -displayModemaps E == - listOfOperatorsSeenSoFar:= nil - for x in E for i in 1.. repeat - for y in x for j in 1.. repeat - for z in y | null member(first z,listOfOperatorsSeenSoFar) and - (modemaps:= LASSOC("modemap",rest z)) repeat - listOfOperatorsSeenSoFar:= [first z,:listOfOperatorsSeenSoFar] - displayOpModemaps(first z,modemaps) - ---% General object traversal functions - -GCOPY ob == COPY ob -- for now - -@ - - -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/clam.boot b/src/interp/clam.boot new file mode 100644 index 00000000..cde11ef3 --- /dev/null +++ b/src/interp/clam.boot @@ -0,0 +1,705 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- 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. + + +import '"g-timer" +)package "BOOT" + +--% Cache Lambda Facility +-- for remembering previous values to functions + +--to CLAM a function f, there must be an entry on $clamList as follows: +-- (functionName --the name of the function to be CLAMed (e.g. f) +-- kind --"hash" or number of values to be stored in +-- circular list +-- eqEtc --the equal function to be used +-- (EQ, EQUAL, UEQUAL,..) +-- "shift" --(opt) for circular lists, shift most recently +-- used to front +-- "count") --(opt) use reference counts (see below) +-- +-- Notes: +-- Functions with "hash" as kind must give EQ, CVEC, or UEQUAL +-- Functions with some other as kind hashed as property +-- lists with eqEtc used to compare entries +-- Functions which have 0 arguments may only be CLAMmed when kind is +-- identifier other than hash (circular/private hashtable for no args +-- makes no sense) +-- +-- Functions which have more than 1 argument must never be CLAMed with EQ +-- since arguments are cached as lists +-- For circular lists, "count" will do "shift"ing; entries with lowest +-- use count are replaced +-- For cache option without "count", all entries are cleared on garbage +-- collection; For cache option with "count", +-- entries have their use count set +-- to 0 on garbage collection; those with 0 use count at garbage collection +-- are cleared +-- see definition of COMP,2 in COMP LISP which calls clamComp below + +-- see SETQ LISP for initial def of $hashNode + +compClam(op,argl,body,$clamList) == + --similar to reportFunctionCompilation in SLAM BOOT + if $InteractiveMode then startTimingProcess 'compilation + if (u:= LASSQ(op,$clamList)) isnt [kind,eqEtc,:options] + then keyedSystemError("S2GE0004",[op]) + $clamList:= nil --clear to avoid looping + if u:= S_-(options,'(shift count)) then + keyedSystemError("S2GE0006",[op,:u]) + shiftFl := MEMQ('shift,options) + countFl := MEMQ('count,options) + if #argl > 1 and eqEtc= 'EQ then + keyedSystemError("S2GE0007",[op]) + (not IDENTP kind) and (not INTEGERP kind or kind < 1) => + keyedSystemError("S2GE0005",[op]) + IDENTP kind => + shiftFl => keyedSystemError("S2GE0008",[op]) + compHash(op,argl,body,(kind='hash => nil; kind),eqEtc,countFl) + cacheCount:= kind + if null argl then keyedSystemError("S2GE0009",[op]) + phrase:= + cacheCount=1 => ['"computed value only"] + [:bright cacheCount,'"computed values"] + sayBrightly [:bright op,'"will save last",:phrase] + auxfn:= INTERNL(op,'";") + g1:= GENSYM() --argument or argument list + [arg,computeValue] := + argl is [.] => [[g1],[auxfn,g1]] --g1 is a parameter + [g1,['APPLX,['function,auxfn],g1]] --g1 is a parameter list + cacheName:= INTERNL(op,'";AL") + if $reportCounts=true then + hitCounter:= INTERNL(op,'";hit") + callCounter:= INTERNL(op,'";calls") + SET(hitCounter,0) + SET(callCounter,0) + callCountCode:= [['SETQ,callCounter,['QSADD1,callCounter]]] + hitCountCode:= [['SETQ,hitCounter,['QSADD1,hitCounter]]] + g2:= GENSYM() --length of cache or arg-value pair + g3:= GENSYM() --value computed by calling function + lookUpFunction:= + shiftFl => + countFl => 'assocCacheShiftCount + 'assocCacheShift + countFl => 'assocCacheCount + 'assocCache + returnFoundValue:= + countFl => ['CDDR,g3] + ['CDR,g3] + namePart:= + countFl => cacheName + MKQ cacheName + secondPredPair:= +-- null argl => [cacheName] + [['SETQ,g3,[lookUpFunction,g1,namePart,eqEtc]], + :hitCountCode, + returnFoundValue] + resetCacheEntry:= + countFl => ['CONS,1,g2] + g2 + thirdPredPair:= +-- null argl => ['(QUOTE T),['SETQ,cacheName,computeValue]] + ['(QUOTE T), + ['SETQ,g2,computeValue], + ['SETQ,g3,['CAR,cacheName]], + ['RPLACA,g3,g1], + ['RPLACD,g3,resetCacheEntry], + g2] + codeBody:= ['PROG,[g2,g3], + :callCountCode, + ['RETURN,['COND,secondPredPair,thirdPredPair]]] + lamex:= ['LAM,arg,codeBody] + mainFunction:= [op,lamex] + computeFunction:= [auxfn,['LAMBDA,argl,:body]] + + -- compile generated function stub + compileInteractive mainFunction + + -- compile main body: this has already been compTran'ed + if $reportCompilation then + sayBrightlyI bright '"Generated LISP code for function:" + pp computeFunction + compileQuietly [computeFunction] + + cacheType:= 'function + cacheResetCode:= ['SETQ,cacheName,['initCache,cacheCount]] + cacheCountCode:= ['countCircularAlist,cacheName,cacheCount] + cacheVector:= mkCacheVec(op,cacheName,cacheType, + cacheResetCode,cacheCountCode) + LAM_,EVALANDFILEACTQ ['PUT, MKQ op, MKQ 'cacheInfo, MKQ cacheVector] + LAM_,EVALANDFILEACTQ cacheResetCode + if $InteractiveMode then stopTimingProcess 'compilation + op + +compHash(op,argl,body,cacheNameOrNil,eqEtc,countFl) == + --Note: when cacheNameOrNil^=nil, it names a global hashtable + +-- cacheNameOrNil => compHashGlobal(op,argl,body,cacheNameOrNil,eqEtc,countFl) +-- This branch to compHashGlobal is now omitted; as a result, +-- entries will be stored on the global hashtable in a uniform way: +-- (, ,:) +-- where the reference count is optional + + if cacheNameOrNil and cacheNameOrNil^='_$ConstructorCache then + keyedSystemError("S2GE0010",[op]) + --restriction due to omission of call to hputNewValue (see *** lines below) + + if null argl then + null cacheNameOrNil => keyedSystemError("S2GE0011",[op]) + nil + (not cacheNameOrNil) and (not MEMQ(eqEtc,'(EQ CVEC UEQUAL))) => + keyedSystemError("S2GE0012",[op]) +--withWithout := (countFl => "with"; "without") +--middle:= +-- cacheNameOrNil => ["on","%b",cacheNameOrNil,"%d"] +-- '"privately " +--sayBrightly +-- ["%b",op,"%d","hashes ",:middle,withWithout," reference counts"] + auxfn:= INTERNL(op,'";") + g1:= GENSYM() --argument or argument list + [arg,cacheArgKey,computeValue] := + -- arg: to be used as formal argument of lambda construction; + -- cacheArgKey: the form used to look up the value in the cache + -- computeValue: the form used to compute the value from arg + null argl => [nil,nil,[auxfn]] + argl is [.] => + key:= (cacheNameOrNil => ['devaluate,g1]; g1) + [[g1],['LIST,key],[auxfn,g1]] --g1 is a parameter + key:= (cacheNameOrNil => ['devaluateList,g1] ; g1) + [g1,key,['APPLY,['function,auxfn],g1]] --g1 is a parameter list + cacheName:= cacheNameOrNil or INTERNL(op,'";AL") + if $reportCounts=true then + hitCounter:= INTERNL(op,'";hit") + callCounter:= INTERNL(op,'";calls") + SET(hitCounter,0) + SET(callCounter,0) + callCountCode:= [['SETQ,callCounter,['QSADD1,callCounter]]] + hitCountCode:= [['SETQ,hitCounter,['QSADD1,hitCounter]]] + g2:= GENSYM() --value computed by calling function + returnFoundValue:= + null argl => + -- if we have a global hastable, functions with no arguments are + -- stored in the same format as those with several arguments, e.g. + -- to cache the value given by f(), the structure + -- ((nil )) is stored in the cache + countFl => ['CDRwithIncrement,['CDAR,g2]] + ['CDAR,g2] + countFl => ['CDRwithIncrement,g2] + g2 + getCode:= + null argl => ['HGET,cacheName,MKQ op] + cacheNameOrNil => + eqEtc^='EQUAL => + ['lassocShiftWithFunction,cacheArgKey, + ['HGET,cacheNameOrNil,MKQ op],MKQ eqEtc] + ['lassocShift,cacheArgKey,['HGET,cacheNameOrNil,MKQ op]] + ['HGET,cacheName,g1] + secondPredPair:= [['SETQ,g2,getCode],:hitCountCode,returnFoundValue] + putCode:= + null argl => + cacheNameOrNil => + countFl => ['CDDAR,['HPUT,cacheNameOrNil,MKQ op, + ['LIST,['CONS,nil,['CONS,1,computeValue]]]]] + ['HPUT,cacheNameOrNil,MKQ op,['LIST,['CONS,nil,computeValue]]] + systemError '"unexpected" + cacheNameOrNil => computeValue + --countFl => ['CDR,['hputNewProp,cacheNameOrNil,MKQ op,cacheArgKey, --*** + -- ['CONS,1,computeValue]]] --*** + --['hputNewProp,cacheNameOrNil,MKQ op,cacheArgKey,computeValue] --*** + countFl => ['CDR,['HPUT,cacheName,g1,['CONS,1,computeValue]]] + ['HPUT,cacheName,g1,computeValue] + if cacheNameOrNil then putCode := + ['UNWIND_-PROTECT,['PROG1,putCode,['SETQ,g2,'T]], + ['COND,[['NOT,g2],['HREM,cacheName,MKQ op]]]] + thirdPredPair:= ['(QUOTE T),putCode] + codeBody:= ['PROG,[g2], + :callCountCode,['RETURN,['COND,secondPredPair,thirdPredPair]]] + lamex:= ['LAM,arg,codeBody] + mainFunction:= [op,lamex] + computeFunction:= [auxfn,['LAMBDA,argl,:body]] + + -- compile generated function stub + compileInteractive mainFunction + + -- compile main body: this has already been compTran'ed + if $reportCompilation then + sayBrightlyI bright '"Generated LISP code for function:" + pp computeFunction + compileQuietly [computeFunction] + + if null cacheNameOrNil then + cacheType:= + countFl => 'hash_-tableWithCounts + 'hash_-table + weakStrong:= (countFl => 'STRONG; 'WEAK) + --note: WEAK means that key/value pairs disappear at garbage collection + cacheResetCode:= + ['SETQ,cacheName,['MAKE_-HASHTABLE,MKQ eqEtc]] + cacheCountCode:= ['hashCount,cacheName] + cacheVector:= + mkCacheVec(op,cacheName,cacheType,cacheResetCode,cacheCountCode) + LAM_,EVALANDFILEACTQ ['PUT, MKQ op, MKQ 'cacheInfo, MKQ cacheVector] + LAM_,EVALANDFILEACTQ cacheResetCode + op + +compHashGlobal(op,argl,body,cacheName,eqEtc,countFl) == + --Note: when cacheNameOrNil^=nil, it names a global hashtable + + if (not MEMQ(eqEtc,'(UEQUAL))) then + sayBrightly "for hash option, only EQ, CVEC, and UEQUAL are allowed" + auxfn:= INTERNL(op,'";") + g1:= GENSYM() --argument or argument list + [arg,cacheArgKey,computeValue] := + -- arg: to be used as formal argument of lambda construction; + -- cacheArgKey: the form used to look up the value in the cache + -- computeValue: the form used to compute the value from arg + application:= + null argl => [auxfn] + argl is [.] => [auxfn,g1] --g1 is a parameter + ['APPLX,['function,auxfn],g1] --g1 is a parameter list + [g1,['consForHashLookup,MKQ op,g1],application] + g2:= GENSYM() --value computed by calling function + returnFoundValue:= + countFl => ['CDRwithIncrement,g2] + g2 + getCode:= ['HGET,cacheName,cacheArgKey] + secondPredPair:= [['SETQ,g2,getCode],returnFoundValue] + putForm:= ['CONS,MKQ op,g1] + putCode:= + countFl => ['HPUT,cacheName,putForm,['CONS,1,computeValue]] + ['HPUT,cacheName,putForm,computeValue] + thirdPredPair:= ['(QUOTE T),putCode] + codeBody:= ['PROG,[g2], ['RETURN,['COND,secondPredPair,thirdPredPair]]] + lamex:= ['LAM,arg,codeBody] + mainFunction:= [op,lamex] + computeFunction:= [auxfn,['LAMBDA,argl,:body]] + compileInteractive mainFunction + compileInteractive computeFunction + op + +consForHashLookup(a,b) == + RPLACA($hashNode,a) + RPLACD($hashNode,b) + $hashNode + +CDRwithIncrement x == + RPLACA(x,QSADD1 CAR x) + CDR x + +HGETandCount(hashTable,prop) == + u:= HGET(hashTable,prop) or return nil + RPLACA(u,QSADD1 CAR u) + u + +clearClams() == + for [fn,kind,:.] in $clamList | kind = 'hash or INTEGERP kind repeat + clearClam fn + +clearClam fn == + infovec:= GETL(fn,'cacheInfo) or keyedSystemError("S2GE0003",[fn]) + eval infovec.cacheReset + +reportAndClearClams() == + cacheStats() + clearClams() + +clearConstructorCaches() == + clearCategoryCaches() + CLRHASH $ConstructorCache + +clearConstructorCache(cname) == + (kind := GETDATABASE(cname,'CONSTRUCTORKIND)) => + kind = 'category => clearCategoryCache cname + HREM($ConstructorCache,cname) + +clearConstructorAndLisplibCaches() == + clearClams() + clearConstructorCaches() + +clearCategoryCaches() == + for name in allConstructors() repeat + if GETDATABASE(name,'CONSTRUCTORKIND) = 'category then + if BOUNDP(cacheName:= INTERNL STRCONC(PNAME name,'";AL")) + then SET(cacheName,nil) + if BOUNDP(cacheName:= INTERNL STRCONC(PNAME name,'";CAT")) + then SET(cacheName,nil) + +clearCategoryCache catName == + cacheName:= INTERNL STRCONC(PNAME catName,'";AL") + SET(cacheName,nil) + +displayHashtable x == + l:= NREVERSE SORTBY('CAR,[[opOf HGET(x,key),key] for key in HKEYS x]) + for [a,b] in l repeat + sayBrightlyNT ['%b,a,'%d] + pp b + +cacheStats() == + for [fn,kind,:u] in $clamList repeat + not MEMQ('count,u) => + sayBrightly ["%b",fn,"%d","does not keep reference counts"] + INTEGERP kind => reportCircularCacheStats(fn,kind) + kind = 'hash => reportHashCacheStats fn + sayBrightly ["Unknown cache type for","%b",fn,"%d"] + +reportCircularCacheStats(fn,n) == + infovec:= GETL(fn,'cacheInfo) + circList:= eval infovec.cacheName + numberUsed := + +/[1 for i in 1..n for x in circList while x isnt [='_$failed,:.]] + sayBrightly ["%b",fn,"%d","has","%b",numberUsed,"%d","/ ",n," values cached"] + displayCacheFrequency mkCircularCountAlist(circList,n) + TERPRI() + +displayCacheFrequency al == + al := NREVERSE SORTBY('CAR,al) + sayBrightlyNT " #hits/#occurrences: " + for [a,:b] in al repeat sayBrightlyNT [a,"/",b," "] + TERPRI() + +mkCircularCountAlist(cl,len) == + for [x,count,:.] in cl for i in 1..len while x ^= '_$failed repeat + u:= assoc(count,al) => RPLACD(u,1 + CDR u) + if INTEGERP $reportFavoritesIfNumber and count >= $reportFavoritesIfNumber then + sayBrightlyNT [" ",count," "] + pp x + al:= [[count,:1],:al] + al + +reportHashCacheStats fn == + infovec:= GETL(fn,'cacheInfo) + hashTable:= eval infovec.cacheName + hashValues:= [HGET(hashTable,key) for key in HKEYS hashTable] + sayBrightly [:bright fn,'"has",:bright(# hashValues),'"values cached."] + displayCacheFrequency mkHashCountAlist hashValues + TERPRI() + +mkHashCountAlist vl == + for [count,:.] in vl repeat + u:= assoc(count,al) => RPLACD(u,1 + CDR u) + al:= [[count,:1],:al] + al + +clearHashReferenceCounts() == + --free all cells with 0 reference counts; clear other counts to 0 + for x in $clamList repeat + x.cacheType='hash_-tableWithCounts => + remHashEntriesWith0Count eval x.cacheName + x.cacheType='hash_-table => CLRHASH eval x.cacheName + +remHashEntriesWith0Count $hashTable == + MAPHASH(function fn,$hashTable) where fn(key,obj) == + CAR obj = 0 => HREM($hashTable,key) --free store + nil + +initCache n == + tail:= '(0 . $failed) + l:= [[$failed,:tail] for i in 1..n] + RPLACD(LASTNODE l,l) + +assocCache(x,cacheName,fn) == + --fn=equality function; do not SHIFT or COUNT + al:= eval cacheName + forwardPointer:= al + val:= nil + until EQ(forwardPointer,al) repeat + FUNCALL(fn,CAAR forwardPointer,x) => return (val:= CAR forwardPointer) + backPointer:= forwardPointer + forwardPointer:= CDR forwardPointer + val => val + SET(cacheName,backPointer) + nil + +assocCacheShift(x,cacheName,fn) == --like ASSOC except that al is circular + --fn=equality function; SHIFT but do not COUNT + al:= eval cacheName + forwardPointer:= al + val:= nil + until EQ(forwardPointer,al) repeat + FUNCALL(fn, CAR (y:=CAR forwardPointer),x) => + if not EQ(forwardPointer,al) then --shift referenced entry to front + RPLACA(forwardPointer,CAR al) + RPLACA(al,y) + return (val:= y) + backPointer := forwardPointer --CAR is slot replaced on failure + forwardPointer:= CDR forwardPointer + val => val + SET(cacheName,backPointer) + nil + +assocCacheShiftCount(x,al,fn) == + -- if x is found, entry containing x becomes first element of list; if + -- x is not found, entry with smallest use count is shifted to front so + -- as to be replaced + --fn=equality function; COUNT and SHIFT + forwardPointer:= al + val:= nil + minCount:= 10000 --preset minCount but not newFrontPointer here + until EQ(forwardPointer,al) repeat + FUNCALL(fn, CAR (y:=CAR forwardPointer),x) => + newFrontPointer := forwardPointer + RPLAC(CADR y,QSADD1 CADR y) --increment use count + return (val:= y) + if QSLESSP(c := CADR y,minCount) then --initial c is 1 so is true 1st time + minCount := c + newFrontPointer := forwardPointer --CAR is slot replaced on failure + forwardPointer:= CDR forwardPointer + if not EQ(newFrontPointer,al) then --shift referenced entry to front + temp:= CAR newFrontPointer --or entry with smallest count + RPLACA(newFrontPointer,CAR al) + RPLACA(al,temp) + val + +clamStats() == + for [op,kind,:.] in $clamList repeat + cacheVec:= GETL(op,'cacheInfo) or systemErrorHere "clamStats" + prefix:= + $reportCounts^= true => nil + hitCounter:= INTERNL(op,'";hit") + callCounter:= INTERNL(op,'";calls") + res:= ["%b",eval hitCounter,"/",eval callCounter,"%d","calls to "] + SET(hitCounter,0) + SET(callCounter,0) + res + postString:= + cacheValue:= eval cacheVec.cacheName + kind = 'hash => [" (","%b",HASH_-TABLE_-COUNT cacheValue,"%d","entries)"] + empties:= numberOfEmptySlots eval cacheVec.cacheName + empties = 0 => nil + [" (","%b",kind-empties,"/",kind,"%d","slots used)"] + sayBrightly + [:prefix,op,:postString] + +numberOfEmptySlots cache== + count:= (CAAR cache ='$failed => 1; 0) + for x in tails rest cache while NE(x,cache) repeat + if CAAR x='$failed then count:= count+1 + count + +addToSlam([name,:argnames],shell) == + $mutableDomain => return nil + null argnames => addToConstructorCache(name,nil,shell) + args:= ['LIST,:[mkDevaluate a for a in argnames]] + addToConstructorCache(name,args,shell) + +addToConstructorCache(op,args,value) == + ['haddProp,'$ConstructorCache,MKQ op,args,['CONS,1,value]] + +haddProp(ht,op,prop,val) == + --called inside functors (except for union and record types ??) + --presently, ht always = $ConstructorCache + statRecordInstantiationEvent() + if $reportInstantiations = true or $reportEachInstantiation = true then + startTimingProcess 'debug + recordInstantiation(op,prop,false) + stopTimingProcess 'debug + u:= HGET(ht,op) => --hope that one exists most of the time + assoc(prop,u) => val --value is already there--must = val; exit now + RPLACD(u,[CAR u,:CDR u]) + RPLACA(u,[prop,:val]) + $op: local := op + listTruncate(u,20) --save at most 20 instantiations + val + HPUT(ht,op,[[prop,:val]]) + val + +recordInstantiation(op,prop,dropIfTrue) == + startTimingProcess 'debug + recordInstantiation1(op,prop,dropIfTrue) + stopTimingProcess 'debug + +recordInstantiation1(op,prop,dropIfTrue) == + op in '(CategoryDefaults RepeatedSquaring) => nil--ignore defaults for now + if $reportEachInstantiation = true then + trailer:= (dropIfTrue => '" dropped"; '" instantiated") + if $insideCoerceInteractive= true then + $instantCoerceCount:= 1+$instantCoerceCount + if $insideCanCoerceFrom is [m1,m2] and null dropIfTrue then + $instantCanCoerceCount:= 1+$instantCanCoerceCount + xtra:= + ['" for ",outputDomainConstructor m1,'"-->",outputDomainConstructor m2] + if $insideEvalMmCondIfTrue = true and null dropIfTrue then + $instantMmCondCount:= $instantMmCondCount + 1 + typeTimePrin ["CONCAT",outputDomainConstructor [op,:prop],trailer,:xtra] + null $reportInstantiations => nil + u:= HGET($instantRecord,op) => --hope that one exists most of the time + v := LASSOC(prop,u) => + dropIfTrue => RPLAC(CDR v,1+CDR v) + RPLAC(CAR v,1+CAR v) + RPLACD(u,[CAR u,:CDR u]) + val := + dropIfTrue => [0,:1] + [1,:0] + RPLACA(u,[prop,:val]) + val := + dropIfTrue => [0,:1] + [1,:0] + HPUT($instantRecord,op,[[prop,:val]]) + +reportInstantiations() == + --assumed to be a hashtable with reference counts + conList:= + [:[[n,m,[key,:argList]] for [argList,n,:m] in HGET($instantRecord,key)] + for key in HKEYS $instantRecord] + sayBrightly ['"# instantiated/# dropped/domain name", + "%l",'"------------------------------------"] + nTotal:= mTotal:= rTotal := nForms:= 0 + for [n,m,form] in NREVERSE SORTBY('CADDR,conList) repeat + nTotal:= nTotal+n; mTotal:= mTotal+m + if n > 1 then rTotal:= rTotal + n-1 + nForms:= nForms + 1 + typeTimePrin ['CONCATB,n,m,outputDomainConstructor form] + sayBrightly ["%b",'"Totals:","%d",nTotal,'" instantiated","%l", + '" ",$instantCoerceCount,'" inside coerceInteractive","%l", + '" ",$instantCanCoerceCount,'" inside canCoerceFrom","%l", + '" ",$instantMmCondCount,'" inside evalMmCond","%l", + '" ",rTotal,'" reinstantiated","%l", + '" ",mTotal,'" dropped","%l", + '" ",nForms,'" distinct domains instantiated/dropped"] + +hputNewProp(ht,op,argList,val) == + --NOTE: obselete if lines *** are commented out + -- Warning!!! This function should only be called for + -- $ConstructorCache slamming --- since it maps devaluate onto prop, an + -- argument list + -- + -- This function may be called when property is already there; for + -- example, Polynomial applied to '(Integer), not finding it in the + -- cache will invoke Polynomial to compute it; inside of Polynomial is + -- a call to this function which will hputNewProp the property onto the + -- cache so that when this function is called by the outer Polynomial, + -- the value will always be there + + prop:= [devaluate x for x in argList] + haddProp(ht,op,prop,val) + +listTruncate(l,n) == + u:= l + n:= QSSUB1 n + while NEQ(n,0) and null atom u repeat + n:= QSSUB1 n + u:= QCDR u + if null atom u then + if null atom rest u and $reportInstantiations = true then + recordInstantiation($op,CAADR u,true) + RPLACD(u,nil) + l + +lassocShift(x,l) == + y:= l + while not atom y repeat + EQUAL(x,CAR QCAR y) => return (result := QCAR y) + y:= QCDR y + result => + if NEQ(y,l) then + QRPLACA(y,CAR l) + QRPLACA(l,result) + QCDR result + nil + +lassocShiftWithFunction(x,l,fn) == + y:= l + while not atom y repeat + FUNCALL(fn,x,CAR QCAR y) => return (result := QCAR y) + y:= QCDR y + result => + if NEQ(y,l) then + QRPLACA(y,CAR l) + QRPLACA(l,result) + QCDR result + nil + +lassocShiftQ(x,l) == + y:= l + while not atom y repeat + EQ(x,CAR CAR y) => return (result := CAR y) + y:= CDR y + result => + if NEQ(y,l) then + RPLACA(y,CAR l) + RPLACA(l,result) + CDR result + nil + +-- rassocShiftQ(x,l) == +-- y:= l +-- while not atom y repeat +-- EQ(x,CDR CAR y) => return (result := CAR y) +-- y:= CDR y +-- result => +-- if NEQ(y,l) then +-- RPLACA(y,CAR l) +-- RPLACA(l,result) +-- CAR result +-- nil + +globalHashtableStats(x,sortFn) == + --assumed to be a hashtable with reference counts + keys:= HKEYS x + for key in keys repeat + u:= HGET(x,key) + for [argList,n,:.] in u repeat + not INTEGERP n => keyedSystemError("S2GE0013",[x]) + argList1:= [constructor2ConstructorForm x for x in argList] + reportList:= [[n,key,argList1],:reportList] + sayBrightly ["%b"," USE NAME ARGS","%d"] + for [n,fn,args] in NREVERSE SORTBY(sortFn,reportList) repeat + sayBrightlyNT [:rightJustifyString(n,6)," ",fn,": "] + pp args + +constructor2ConstructorForm x == + VECP x => x.0 + x + +rightJustifyString(x,maxWidth) == + size:= entryWidth x + size > maxWidth => keyedSystemError("S2GE0014",[x]) + [fillerSpaces(maxWidth-size," "),x] + +domainEqualList(argl1,argl2) == + --function used to match argument lists of constructors + while argl1 and argl2 repeat + item1:= devaluate CAR argl1 + item2:= CAR argl2 + partsMatch:= + item1 = item2 => true + false + null partsMatch => return nil + argl1:= rest argl1; argl2 := rest argl2 + argl1 or argl2 => nil + true + +removeAllClams() == + for [fun,:.] in $clamList repeat + sayBrightly ['"Un-clamming function",'%b,fun,'%d] + SET(fun,eval INTERN STRCONC(STRINGIMAGE fun,'";")) diff --git a/src/interp/clam.boot.pamphlet b/src/interp/clam.boot.pamphlet deleted file mode 100644 index 985bb006..00000000 --- a/src/interp/clam.boot.pamphlet +++ /dev/null @@ -1,730 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{/src/interp/clam.boot} Pamphlet} -\author{The Axiom Team} - -\begin{document} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\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. - -@ -<<*>>= -<> - -import '"g-timer" -)package "BOOT" - ---% Cache Lambda Facility --- for remembering previous values to functions - ---to CLAM a function f, there must be an entry on $clamList as follows: --- (functionName --the name of the function to be CLAMed (e.g. f) --- kind --"hash" or number of values to be stored in --- circular list --- eqEtc --the equal function to be used --- (EQ, EQUAL, UEQUAL,..) --- "shift" --(opt) for circular lists, shift most recently --- used to front --- "count") --(opt) use reference counts (see below) --- --- Notes: --- Functions with "hash" as kind must give EQ, CVEC, or UEQUAL --- Functions with some other as kind hashed as property --- lists with eqEtc used to compare entries --- Functions which have 0 arguments may only be CLAMmed when kind is --- identifier other than hash (circular/private hashtable for no args --- makes no sense) --- --- Functions which have more than 1 argument must never be CLAMed with EQ --- since arguments are cached as lists --- For circular lists, "count" will do "shift"ing; entries with lowest --- use count are replaced --- For cache option without "count", all entries are cleared on garbage --- collection; For cache option with "count", --- entries have their use count set --- to 0 on garbage collection; those with 0 use count at garbage collection --- are cleared --- see definition of COMP,2 in COMP LISP which calls clamComp below - --- see SETQ LISP for initial def of $hashNode - -compClam(op,argl,body,$clamList) == - --similar to reportFunctionCompilation in SLAM BOOT - if $InteractiveMode then startTimingProcess 'compilation - if (u:= LASSQ(op,$clamList)) isnt [kind,eqEtc,:options] - then keyedSystemError("S2GE0004",[op]) - $clamList:= nil --clear to avoid looping - if u:= S_-(options,'(shift count)) then - keyedSystemError("S2GE0006",[op,:u]) - shiftFl := MEMQ('shift,options) - countFl := MEMQ('count,options) - if #argl > 1 and eqEtc= 'EQ then - keyedSystemError("S2GE0007",[op]) - (not IDENTP kind) and (not INTEGERP kind or kind < 1) => - keyedSystemError("S2GE0005",[op]) - IDENTP kind => - shiftFl => keyedSystemError("S2GE0008",[op]) - compHash(op,argl,body,(kind='hash => nil; kind),eqEtc,countFl) - cacheCount:= kind - if null argl then keyedSystemError("S2GE0009",[op]) - phrase:= - cacheCount=1 => ['"computed value only"] - [:bright cacheCount,'"computed values"] - sayBrightly [:bright op,'"will save last",:phrase] - auxfn:= INTERNL(op,'";") - g1:= GENSYM() --argument or argument list - [arg,computeValue] := - argl is [.] => [[g1],[auxfn,g1]] --g1 is a parameter - [g1,['APPLX,['function,auxfn],g1]] --g1 is a parameter list - cacheName:= INTERNL(op,'";AL") - if $reportCounts=true then - hitCounter:= INTERNL(op,'";hit") - callCounter:= INTERNL(op,'";calls") - SET(hitCounter,0) - SET(callCounter,0) - callCountCode:= [['SETQ,callCounter,['QSADD1,callCounter]]] - hitCountCode:= [['SETQ,hitCounter,['QSADD1,hitCounter]]] - g2:= GENSYM() --length of cache or arg-value pair - g3:= GENSYM() --value computed by calling function - lookUpFunction:= - shiftFl => - countFl => 'assocCacheShiftCount - 'assocCacheShift - countFl => 'assocCacheCount - 'assocCache - returnFoundValue:= - countFl => ['CDDR,g3] - ['CDR,g3] - namePart:= - countFl => cacheName - MKQ cacheName - secondPredPair:= --- null argl => [cacheName] - [['SETQ,g3,[lookUpFunction,g1,namePart,eqEtc]], - :hitCountCode, - returnFoundValue] - resetCacheEntry:= - countFl => ['CONS,1,g2] - g2 - thirdPredPair:= --- null argl => ['(QUOTE T),['SETQ,cacheName,computeValue]] - ['(QUOTE T), - ['SETQ,g2,computeValue], - ['SETQ,g3,['CAR,cacheName]], - ['RPLACA,g3,g1], - ['RPLACD,g3,resetCacheEntry], - g2] - codeBody:= ['PROG,[g2,g3], - :callCountCode, - ['RETURN,['COND,secondPredPair,thirdPredPair]]] - lamex:= ['LAM,arg,codeBody] - mainFunction:= [op,lamex] - computeFunction:= [auxfn,['LAMBDA,argl,:body]] - - -- compile generated function stub - compileInteractive mainFunction - - -- compile main body: this has already been compTran'ed - if $reportCompilation then - sayBrightlyI bright '"Generated LISP code for function:" - pp computeFunction - compileQuietly [computeFunction] - - cacheType:= 'function - cacheResetCode:= ['SETQ,cacheName,['initCache,cacheCount]] - cacheCountCode:= ['countCircularAlist,cacheName,cacheCount] - cacheVector:= mkCacheVec(op,cacheName,cacheType, - cacheResetCode,cacheCountCode) - LAM_,EVALANDFILEACTQ ['PUT, MKQ op, MKQ 'cacheInfo, MKQ cacheVector] - LAM_,EVALANDFILEACTQ cacheResetCode - if $InteractiveMode then stopTimingProcess 'compilation - op - -compHash(op,argl,body,cacheNameOrNil,eqEtc,countFl) == - --Note: when cacheNameOrNil^=nil, it names a global hashtable - --- cacheNameOrNil => compHashGlobal(op,argl,body,cacheNameOrNil,eqEtc,countFl) --- This branch to compHashGlobal is now omitted; as a result, --- entries will be stored on the global hashtable in a uniform way: --- (, ,:) --- where the reference count is optional - - if cacheNameOrNil and cacheNameOrNil^='_$ConstructorCache then - keyedSystemError("S2GE0010",[op]) - --restriction due to omission of call to hputNewValue (see *** lines below) - - if null argl then - null cacheNameOrNil => keyedSystemError("S2GE0011",[op]) - nil - (not cacheNameOrNil) and (not MEMQ(eqEtc,'(EQ CVEC UEQUAL))) => - keyedSystemError("S2GE0012",[op]) ---withWithout := (countFl => "with"; "without") ---middle:= --- cacheNameOrNil => ["on","%b",cacheNameOrNil,"%d"] --- '"privately " ---sayBrightly --- ["%b",op,"%d","hashes ",:middle,withWithout," reference counts"] - auxfn:= INTERNL(op,'";") - g1:= GENSYM() --argument or argument list - [arg,cacheArgKey,computeValue] := - -- arg: to be used as formal argument of lambda construction; - -- cacheArgKey: the form used to look up the value in the cache - -- computeValue: the form used to compute the value from arg - null argl => [nil,nil,[auxfn]] - argl is [.] => - key:= (cacheNameOrNil => ['devaluate,g1]; g1) - [[g1],['LIST,key],[auxfn,g1]] --g1 is a parameter - key:= (cacheNameOrNil => ['devaluateList,g1] ; g1) - [g1,key,['APPLY,['function,auxfn],g1]] --g1 is a parameter list - cacheName:= cacheNameOrNil or INTERNL(op,'";AL") - if $reportCounts=true then - hitCounter:= INTERNL(op,'";hit") - callCounter:= INTERNL(op,'";calls") - SET(hitCounter,0) - SET(callCounter,0) - callCountCode:= [['SETQ,callCounter,['QSADD1,callCounter]]] - hitCountCode:= [['SETQ,hitCounter,['QSADD1,hitCounter]]] - g2:= GENSYM() --value computed by calling function - returnFoundValue:= - null argl => - -- if we have a global hastable, functions with no arguments are - -- stored in the same format as those with several arguments, e.g. - -- to cache the value given by f(), the structure - -- ((nil )) is stored in the cache - countFl => ['CDRwithIncrement,['CDAR,g2]] - ['CDAR,g2] - countFl => ['CDRwithIncrement,g2] - g2 - getCode:= - null argl => ['HGET,cacheName,MKQ op] - cacheNameOrNil => - eqEtc^='EQUAL => - ['lassocShiftWithFunction,cacheArgKey, - ['HGET,cacheNameOrNil,MKQ op],MKQ eqEtc] - ['lassocShift,cacheArgKey,['HGET,cacheNameOrNil,MKQ op]] - ['HGET,cacheName,g1] - secondPredPair:= [['SETQ,g2,getCode],:hitCountCode,returnFoundValue] - putCode:= - null argl => - cacheNameOrNil => - countFl => ['CDDAR,['HPUT,cacheNameOrNil,MKQ op, - ['LIST,['CONS,nil,['CONS,1,computeValue]]]]] - ['HPUT,cacheNameOrNil,MKQ op,['LIST,['CONS,nil,computeValue]]] - systemError '"unexpected" - cacheNameOrNil => computeValue - --countFl => ['CDR,['hputNewProp,cacheNameOrNil,MKQ op,cacheArgKey, --*** - -- ['CONS,1,computeValue]]] --*** - --['hputNewProp,cacheNameOrNil,MKQ op,cacheArgKey,computeValue] --*** - countFl => ['CDR,['HPUT,cacheName,g1,['CONS,1,computeValue]]] - ['HPUT,cacheName,g1,computeValue] - if cacheNameOrNil then putCode := - ['UNWIND_-PROTECT,['PROG1,putCode,['SETQ,g2,'T]], - ['COND,[['NOT,g2],['HREM,cacheName,MKQ op]]]] - thirdPredPair:= ['(QUOTE T),putCode] - codeBody:= ['PROG,[g2], - :callCountCode,['RETURN,['COND,secondPredPair,thirdPredPair]]] - lamex:= ['LAM,arg,codeBody] - mainFunction:= [op,lamex] - computeFunction:= [auxfn,['LAMBDA,argl,:body]] - - -- compile generated function stub - compileInteractive mainFunction - - -- compile main body: this has already been compTran'ed - if $reportCompilation then - sayBrightlyI bright '"Generated LISP code for function:" - pp computeFunction - compileQuietly [computeFunction] - - if null cacheNameOrNil then - cacheType:= - countFl => 'hash_-tableWithCounts - 'hash_-table - weakStrong:= (countFl => 'STRONG; 'WEAK) - --note: WEAK means that key/value pairs disappear at garbage collection - cacheResetCode:= - ['SETQ,cacheName,['MAKE_-HASHTABLE,MKQ eqEtc]] - cacheCountCode:= ['hashCount,cacheName] - cacheVector:= - mkCacheVec(op,cacheName,cacheType,cacheResetCode,cacheCountCode) - LAM_,EVALANDFILEACTQ ['PUT, MKQ op, MKQ 'cacheInfo, MKQ cacheVector] - LAM_,EVALANDFILEACTQ cacheResetCode - op - -compHashGlobal(op,argl,body,cacheName,eqEtc,countFl) == - --Note: when cacheNameOrNil^=nil, it names a global hashtable - - if (not MEMQ(eqEtc,'(UEQUAL))) then - sayBrightly "for hash option, only EQ, CVEC, and UEQUAL are allowed" - auxfn:= INTERNL(op,'";") - g1:= GENSYM() --argument or argument list - [arg,cacheArgKey,computeValue] := - -- arg: to be used as formal argument of lambda construction; - -- cacheArgKey: the form used to look up the value in the cache - -- computeValue: the form used to compute the value from arg - application:= - null argl => [auxfn] - argl is [.] => [auxfn,g1] --g1 is a parameter - ['APPLX,['function,auxfn],g1] --g1 is a parameter list - [g1,['consForHashLookup,MKQ op,g1],application] - g2:= GENSYM() --value computed by calling function - returnFoundValue:= - countFl => ['CDRwithIncrement,g2] - g2 - getCode:= ['HGET,cacheName,cacheArgKey] - secondPredPair:= [['SETQ,g2,getCode],returnFoundValue] - putForm:= ['CONS,MKQ op,g1] - putCode:= - countFl => ['HPUT,cacheName,putForm,['CONS,1,computeValue]] - ['HPUT,cacheName,putForm,computeValue] - thirdPredPair:= ['(QUOTE T),putCode] - codeBody:= ['PROG,[g2], ['RETURN,['COND,secondPredPair,thirdPredPair]]] - lamex:= ['LAM,arg,codeBody] - mainFunction:= [op,lamex] - computeFunction:= [auxfn,['LAMBDA,argl,:body]] - compileInteractive mainFunction - compileInteractive computeFunction - op - -consForHashLookup(a,b) == - RPLACA($hashNode,a) - RPLACD($hashNode,b) - $hashNode - -CDRwithIncrement x == - RPLACA(x,QSADD1 CAR x) - CDR x - -HGETandCount(hashTable,prop) == - u:= HGET(hashTable,prop) or return nil - RPLACA(u,QSADD1 CAR u) - u - -clearClams() == - for [fn,kind,:.] in $clamList | kind = 'hash or INTEGERP kind repeat - clearClam fn - -clearClam fn == - infovec:= GETL(fn,'cacheInfo) or keyedSystemError("S2GE0003",[fn]) - eval infovec.cacheReset - -reportAndClearClams() == - cacheStats() - clearClams() - -clearConstructorCaches() == - clearCategoryCaches() - CLRHASH $ConstructorCache - -clearConstructorCache(cname) == - (kind := GETDATABASE(cname,'CONSTRUCTORKIND)) => - kind = 'category => clearCategoryCache cname - HREM($ConstructorCache,cname) - -clearConstructorAndLisplibCaches() == - clearClams() - clearConstructorCaches() - -clearCategoryCaches() == - for name in allConstructors() repeat - if GETDATABASE(name,'CONSTRUCTORKIND) = 'category then - if BOUNDP(cacheName:= INTERNL STRCONC(PNAME name,'";AL")) - then SET(cacheName,nil) - if BOUNDP(cacheName:= INTERNL STRCONC(PNAME name,'";CAT")) - then SET(cacheName,nil) - -clearCategoryCache catName == - cacheName:= INTERNL STRCONC(PNAME catName,'";AL") - SET(cacheName,nil) - -displayHashtable x == - l:= NREVERSE SORTBY('CAR,[[opOf HGET(x,key),key] for key in HKEYS x]) - for [a,b] in l repeat - sayBrightlyNT ['%b,a,'%d] - pp b - -cacheStats() == - for [fn,kind,:u] in $clamList repeat - not MEMQ('count,u) => - sayBrightly ["%b",fn,"%d","does not keep reference counts"] - INTEGERP kind => reportCircularCacheStats(fn,kind) - kind = 'hash => reportHashCacheStats fn - sayBrightly ["Unknown cache type for","%b",fn,"%d"] - -reportCircularCacheStats(fn,n) == - infovec:= GETL(fn,'cacheInfo) - circList:= eval infovec.cacheName - numberUsed := - +/[1 for i in 1..n for x in circList while x isnt [='_$failed,:.]] - sayBrightly ["%b",fn,"%d","has","%b",numberUsed,"%d","/ ",n," values cached"] - displayCacheFrequency mkCircularCountAlist(circList,n) - TERPRI() - -displayCacheFrequency al == - al := NREVERSE SORTBY('CAR,al) - sayBrightlyNT " #hits/#occurrences: " - for [a,:b] in al repeat sayBrightlyNT [a,"/",b," "] - TERPRI() - -mkCircularCountAlist(cl,len) == - for [x,count,:.] in cl for i in 1..len while x ^= '_$failed repeat - u:= assoc(count,al) => RPLACD(u,1 + CDR u) - if INTEGERP $reportFavoritesIfNumber and count >= $reportFavoritesIfNumber then - sayBrightlyNT [" ",count," "] - pp x - al:= [[count,:1],:al] - al - -reportHashCacheStats fn == - infovec:= GETL(fn,'cacheInfo) - hashTable:= eval infovec.cacheName - hashValues:= [HGET(hashTable,key) for key in HKEYS hashTable] - sayBrightly [:bright fn,'"has",:bright(# hashValues),'"values cached."] - displayCacheFrequency mkHashCountAlist hashValues - TERPRI() - -mkHashCountAlist vl == - for [count,:.] in vl repeat - u:= assoc(count,al) => RPLACD(u,1 + CDR u) - al:= [[count,:1],:al] - al - -clearHashReferenceCounts() == - --free all cells with 0 reference counts; clear other counts to 0 - for x in $clamList repeat - x.cacheType='hash_-tableWithCounts => - remHashEntriesWith0Count eval x.cacheName - x.cacheType='hash_-table => CLRHASH eval x.cacheName - -remHashEntriesWith0Count $hashTable == - MAPHASH(function fn,$hashTable) where fn(key,obj) == - CAR obj = 0 => HREM($hashTable,key) --free store - nil - -initCache n == - tail:= '(0 . $failed) - l:= [[$failed,:tail] for i in 1..n] - RPLACD(LASTNODE l,l) - -assocCache(x,cacheName,fn) == - --fn=equality function; do not SHIFT or COUNT - al:= eval cacheName - forwardPointer:= al - val:= nil - until EQ(forwardPointer,al) repeat - FUNCALL(fn,CAAR forwardPointer,x) => return (val:= CAR forwardPointer) - backPointer:= forwardPointer - forwardPointer:= CDR forwardPointer - val => val - SET(cacheName,backPointer) - nil - -assocCacheShift(x,cacheName,fn) == --like ASSOC except that al is circular - --fn=equality function; SHIFT but do not COUNT - al:= eval cacheName - forwardPointer:= al - val:= nil - until EQ(forwardPointer,al) repeat - FUNCALL(fn, CAR (y:=CAR forwardPointer),x) => - if not EQ(forwardPointer,al) then --shift referenced entry to front - RPLACA(forwardPointer,CAR al) - RPLACA(al,y) - return (val:= y) - backPointer := forwardPointer --CAR is slot replaced on failure - forwardPointer:= CDR forwardPointer - val => val - SET(cacheName,backPointer) - nil - -assocCacheShiftCount(x,al,fn) == - -- if x is found, entry containing x becomes first element of list; if - -- x is not found, entry with smallest use count is shifted to front so - -- as to be replaced - --fn=equality function; COUNT and SHIFT - forwardPointer:= al - val:= nil - minCount:= 10000 --preset minCount but not newFrontPointer here - until EQ(forwardPointer,al) repeat - FUNCALL(fn, CAR (y:=CAR forwardPointer),x) => - newFrontPointer := forwardPointer - RPLAC(CADR y,QSADD1 CADR y) --increment use count - return (val:= y) - if QSLESSP(c := CADR y,minCount) then --initial c is 1 so is true 1st time - minCount := c - newFrontPointer := forwardPointer --CAR is slot replaced on failure - forwardPointer:= CDR forwardPointer - if not EQ(newFrontPointer,al) then --shift referenced entry to front - temp:= CAR newFrontPointer --or entry with smallest count - RPLACA(newFrontPointer,CAR al) - RPLACA(al,temp) - val - -clamStats() == - for [op,kind,:.] in $clamList repeat - cacheVec:= GETL(op,'cacheInfo) or systemErrorHere "clamStats" - prefix:= - $reportCounts^= true => nil - hitCounter:= INTERNL(op,'";hit") - callCounter:= INTERNL(op,'";calls") - res:= ["%b",eval hitCounter,"/",eval callCounter,"%d","calls to "] - SET(hitCounter,0) - SET(callCounter,0) - res - postString:= - cacheValue:= eval cacheVec.cacheName - kind = 'hash => [" (","%b",HASH_-TABLE_-COUNT cacheValue,"%d","entries)"] - empties:= numberOfEmptySlots eval cacheVec.cacheName - empties = 0 => nil - [" (","%b",kind-empties,"/",kind,"%d","slots used)"] - sayBrightly - [:prefix,op,:postString] - -numberOfEmptySlots cache== - count:= (CAAR cache ='$failed => 1; 0) - for x in tails rest cache while NE(x,cache) repeat - if CAAR x='$failed then count:= count+1 - count - -addToSlam([name,:argnames],shell) == - $mutableDomain => return nil - null argnames => addToConstructorCache(name,nil,shell) - args:= ['LIST,:[mkDevaluate a for a in argnames]] - addToConstructorCache(name,args,shell) - -addToConstructorCache(op,args,value) == - ['haddProp,'$ConstructorCache,MKQ op,args,['CONS,1,value]] - -haddProp(ht,op,prop,val) == - --called inside functors (except for union and record types ??) - --presently, ht always = $ConstructorCache - statRecordInstantiationEvent() - if $reportInstantiations = true or $reportEachInstantiation = true then - startTimingProcess 'debug - recordInstantiation(op,prop,false) - stopTimingProcess 'debug - u:= HGET(ht,op) => --hope that one exists most of the time - assoc(prop,u) => val --value is already there--must = val; exit now - RPLACD(u,[CAR u,:CDR u]) - RPLACA(u,[prop,:val]) - $op: local := op - listTruncate(u,20) --save at most 20 instantiations - val - HPUT(ht,op,[[prop,:val]]) - val - -recordInstantiation(op,prop,dropIfTrue) == - startTimingProcess 'debug - recordInstantiation1(op,prop,dropIfTrue) - stopTimingProcess 'debug - -recordInstantiation1(op,prop,dropIfTrue) == - op in '(CategoryDefaults RepeatedSquaring) => nil--ignore defaults for now - if $reportEachInstantiation = true then - trailer:= (dropIfTrue => '" dropped"; '" instantiated") - if $insideCoerceInteractive= true then - $instantCoerceCount:= 1+$instantCoerceCount - if $insideCanCoerceFrom is [m1,m2] and null dropIfTrue then - $instantCanCoerceCount:= 1+$instantCanCoerceCount - xtra:= - ['" for ",outputDomainConstructor m1,'"-->",outputDomainConstructor m2] - if $insideEvalMmCondIfTrue = true and null dropIfTrue then - $instantMmCondCount:= $instantMmCondCount + 1 - typeTimePrin ["CONCAT",outputDomainConstructor [op,:prop],trailer,:xtra] - null $reportInstantiations => nil - u:= HGET($instantRecord,op) => --hope that one exists most of the time - v := LASSOC(prop,u) => - dropIfTrue => RPLAC(CDR v,1+CDR v) - RPLAC(CAR v,1+CAR v) - RPLACD(u,[CAR u,:CDR u]) - val := - dropIfTrue => [0,:1] - [1,:0] - RPLACA(u,[prop,:val]) - val := - dropIfTrue => [0,:1] - [1,:0] - HPUT($instantRecord,op,[[prop,:val]]) - -reportInstantiations() == - --assumed to be a hashtable with reference counts - conList:= - [:[[n,m,[key,:argList]] for [argList,n,:m] in HGET($instantRecord,key)] - for key in HKEYS $instantRecord] - sayBrightly ['"# instantiated/# dropped/domain name", - "%l",'"------------------------------------"] - nTotal:= mTotal:= rTotal := nForms:= 0 - for [n,m,form] in NREVERSE SORTBY('CADDR,conList) repeat - nTotal:= nTotal+n; mTotal:= mTotal+m - if n > 1 then rTotal:= rTotal + n-1 - nForms:= nForms + 1 - typeTimePrin ['CONCATB,n,m,outputDomainConstructor form] - sayBrightly ["%b",'"Totals:","%d",nTotal,'" instantiated","%l", - '" ",$instantCoerceCount,'" inside coerceInteractive","%l", - '" ",$instantCanCoerceCount,'" inside canCoerceFrom","%l", - '" ",$instantMmCondCount,'" inside evalMmCond","%l", - '" ",rTotal,'" reinstantiated","%l", - '" ",mTotal,'" dropped","%l", - '" ",nForms,'" distinct domains instantiated/dropped"] - -hputNewProp(ht,op,argList,val) == - --NOTE: obselete if lines *** are commented out - -- Warning!!! This function should only be called for - -- $ConstructorCache slamming --- since it maps devaluate onto prop, an - -- argument list - -- - -- This function may be called when property is already there; for - -- example, Polynomial applied to '(Integer), not finding it in the - -- cache will invoke Polynomial to compute it; inside of Polynomial is - -- a call to this function which will hputNewProp the property onto the - -- cache so that when this function is called by the outer Polynomial, - -- the value will always be there - - prop:= [devaluate x for x in argList] - haddProp(ht,op,prop,val) - -listTruncate(l,n) == - u:= l - n:= QSSUB1 n - while NEQ(n,0) and null atom u repeat - n:= QSSUB1 n - u:= QCDR u - if null atom u then - if null atom rest u and $reportInstantiations = true then - recordInstantiation($op,CAADR u,true) - RPLACD(u,nil) - l - -lassocShift(x,l) == - y:= l - while not atom y repeat - EQUAL(x,CAR QCAR y) => return (result := QCAR y) - y:= QCDR y - result => - if NEQ(y,l) then - QRPLACA(y,CAR l) - QRPLACA(l,result) - QCDR result - nil - -lassocShiftWithFunction(x,l,fn) == - y:= l - while not atom y repeat - FUNCALL(fn,x,CAR QCAR y) => return (result := QCAR y) - y:= QCDR y - result => - if NEQ(y,l) then - QRPLACA(y,CAR l) - QRPLACA(l,result) - QCDR result - nil - -lassocShiftQ(x,l) == - y:= l - while not atom y repeat - EQ(x,CAR CAR y) => return (result := CAR y) - y:= CDR y - result => - if NEQ(y,l) then - RPLACA(y,CAR l) - RPLACA(l,result) - CDR result - nil - --- rassocShiftQ(x,l) == --- y:= l --- while not atom y repeat --- EQ(x,CDR CAR y) => return (result := CAR y) --- y:= CDR y --- result => --- if NEQ(y,l) then --- RPLACA(y,CAR l) --- RPLACA(l,result) --- CAR result --- nil - -globalHashtableStats(x,sortFn) == - --assumed to be a hashtable with reference counts - keys:= HKEYS x - for key in keys repeat - u:= HGET(x,key) - for [argList,n,:.] in u repeat - not INTEGERP n => keyedSystemError("S2GE0013",[x]) - argList1:= [constructor2ConstructorForm x for x in argList] - reportList:= [[n,key,argList1],:reportList] - sayBrightly ["%b"," USE NAME ARGS","%d"] - for [n,fn,args] in NREVERSE SORTBY(sortFn,reportList) repeat - sayBrightlyNT [:rightJustifyString(n,6)," ",fn,": "] - pp args - -constructor2ConstructorForm x == - VECP x => x.0 - x - -rightJustifyString(x,maxWidth) == - size:= entryWidth x - size > maxWidth => keyedSystemError("S2GE0014",[x]) - [fillerSpaces(maxWidth-size," "),x] - -domainEqualList(argl1,argl2) == - --function used to match argument lists of constructors - while argl1 and argl2 repeat - item1:= devaluate CAR argl1 - item2:= CAR argl2 - partsMatch:= - item1 = item2 => true - false - null partsMatch => return nil - argl1:= rest argl1; argl2 := rest argl2 - argl1 or argl2 => nil - true - -removeAllClams() == - for [fun,:.] in $clamList repeat - sayBrightly ['"Un-clamming function",'%b,fun,'%d] - SET(fun,eval INTERN STRCONC(STRINGIMAGE fun,'";")) -@ - - -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/cparse.boot b/src/interp/cparse.boot index c49ee250..4193670f 100644 --- a/src/interp/cparse.boot +++ b/src/interp/cparse.boot @@ -1,5 +1,7 @@ -- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are diff --git a/src/interp/cstream.boot b/src/interp/cstream.boot new file mode 100644 index 00000000..d935de69 --- /dev/null +++ b/src/interp/cstream.boot @@ -0,0 +1,113 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- 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. + + +import '"sys-macros" + +)package "BOOT" + +--% Stream Utilities + +npNull x== StreamNull x + +StreamNull x== + null x or EQCAR (x,"nullstream") => true + while EQCAR(x,"nonnullstream") repeat + st:=APPLY(CADR x,CDDR x) + RPLACA(x,CAR st) + RPLACD(x,CDR st) + EQCAR(x,"nullstream") + +Delay(f,x)==cons("nonnullstream",[f,:x]) + +StreamNil:= ["nullstream"] + +incRgen s==Delay(function incRgen1,[s]) + +incRgen1(:z)== + [s]:=z + a:=shoeread_-line s + if NULL a + then (CLOSE s;StreamNil) + + else cons(a,incRgen s) + +incIgen n==Delay(function incIgen1,[n]) +incIgen1(:z)== + [n]:=z + n:=n+1 + cons(n,incIgen n) + +incZip(g,f1,f2)==Delay(function incZip1,[g,f1,f2]) +incZip1(:z)== + [g,f1,f2]:=z + StreamNull f1 => StreamNil + StreamNull f2 => StreamNil + cons(FUNCALL(g,car f1,car f2),incZip(g,cdr f1,cdr f2)) + +incAppend(x,y)==Delay(function incAppend1,[x,y]) + +incAppend1(:z)== + [x,y]:=z + if StreamNull x + then if StreamNull y + then StreamNil + else y + else cons(car x,incAppend(cdr x,y)) + +next(f,s)==Delay(function next1,[f,s]) +next1(:z)== + [f,s]:=z + StreamNull s=> StreamNil + h:= APPLY(f, [s]) + incAppend(car h,next(f,cdr h)) + +nextown(f,g,s)==Delay(function nextown1,[f,g,s]) +nextown1 (:z)== + [f,g,s]:=z + StreamNull s=> + spadcall1 g + StreamNil + StreamNull s + h:=spadcall2 (f, s) + incAppend(car h,nextown(f,g,cdr h)) + +nextown2(f,g,e,x)==nextown(cons(f,e),cons(g,e),x) + +spadcall1(g)== + [impl, :env] := g + APPLY(impl, [env]) + +spadcall2(f,args) == + [impl, :env] := f + APPLY(impl, [args, env]) diff --git a/src/interp/cstream.boot.pamphlet b/src/interp/cstream.boot.pamphlet deleted file mode 100644 index 46be9728..00000000 --- a/src/interp/cstream.boot.pamphlet +++ /dev/null @@ -1,147 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp cstream.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -The input stream is parsed into a large s-expression by repeated calls -to Delay. Delay takes a function f and an argument x and returns a list -consisting of ("nonnullstream" f x). Eventually multiple calls are made -and a large list structure is created that consists of -("nonnullstream" f x ("nonnullstream" f1 x1 ("nonnullstream" f2 x2... - -This delay structure is given to StreamNull which walks along the -list looking at the head. If the head is "nonnullstream" then the -function is applied to the argument. - -So, in effect, the input is "zipped up" into a Delay data structure -which is then evaluated by calling StreamNull. This "zippered stream" -parser was a research project at IBM and Axiom was the testbed (which -explains the strange parsing technique). -\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. - -@ -<<*>>= -<> - -import '"sys-macros" - -)package "BOOT" - ---% Stream Utilities - -npNull x== StreamNull x - -StreamNull x== - null x or EQCAR (x,"nullstream") => true - while EQCAR(x,"nonnullstream") repeat - st:=APPLY(CADR x,CDDR x) - RPLACA(x,CAR st) - RPLACD(x,CDR st) - EQCAR(x,"nullstream") - -Delay(f,x)==cons("nonnullstream",[f,:x]) - -StreamNil:= ["nullstream"] - -incRgen s==Delay(function incRgen1,[s]) - -incRgen1(:z)== - [s]:=z - a:=shoeread_-line s - if NULL a - then (CLOSE s;StreamNil) - - else cons(a,incRgen s) - -incIgen n==Delay(function incIgen1,[n]) -incIgen1(:z)== - [n]:=z - n:=n+1 - cons(n,incIgen n) - -incZip(g,f1,f2)==Delay(function incZip1,[g,f1,f2]) -incZip1(:z)== - [g,f1,f2]:=z - StreamNull f1 => StreamNil - StreamNull f2 => StreamNil - cons(FUNCALL(g,car f1,car f2),incZip(g,cdr f1,cdr f2)) - -incAppend(x,y)==Delay(function incAppend1,[x,y]) - -incAppend1(:z)== - [x,y]:=z - if StreamNull x - then if StreamNull y - then StreamNil - else y - else cons(car x,incAppend(cdr x,y)) - -next(f,s)==Delay(function next1,[f,s]) -next1(:z)== - [f,s]:=z - StreamNull s=> StreamNil - h:= APPLY(f, [s]) - incAppend(car h,next(f,cdr h)) - -nextown(f,g,s)==Delay(function nextown1,[f,g,s]) -nextown1 (:z)== - [f,g,s]:=z - StreamNull s=> - spadcall1 g - StreamNil - StreamNull s - h:=spadcall2 (f, s) - incAppend(car h,nextown(f,g,cdr h)) - -nextown2(f,g,e,x)==nextown(cons(f,e),cons(g,e),x) - -spadcall1(g)== - [impl, :env] := g - APPLY(impl, [env]) - -spadcall2(f,args) == - [impl, :env] := f - APPLY(impl, [args, env]) -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/format.boot b/src/interp/format.boot new file mode 100644 index 00000000..3c7b75e3 --- /dev/null +++ b/src/interp/format.boot @@ -0,0 +1,787 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- 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. + + +import '"macros" +)package "BOOT" + +--% Functions for display formatting system objects + +-- some of these are redundant and should be compacted +$formatSigAsTeX := 1 + +--% Formatting modemaps + +sayModemap m == + -- sayMSG formatModemap displayTranModemap m + sayMSG formatModemap old2NewModemaps displayTranModemap m + +sayModemapWithNumber(m,n) == + msg := reverse cleanUpSegmentedMsg reverse ["%i","%i",'" ", + STRCONC(lbrkSch(),object2String n,rbrkSch()), + :formatModemap displayTranModemap m,"%u","%u"] + sayMSG flowSegmentedMsg(reverse msg,$LINELENGTH,3) + +displayOpModemaps(op,modemaps) == + TERPRI() + count:= #modemaps + phrase:= (count=1 => 'modemap;'modemaps) + sayMSG ['%b,count,'%d,phrase,'" for",'%b,op,'%d,'":"] + for modemap in modemaps repeat sayModemap modemap + +displayTranModemap (mm is [[x,:sig],[pred,:y],:z]) == + -- The next 8 lines are a HACK to deal with the "partial" definition + -- JHD/RSS + if pred is ['partial,:pred'] then + [b,:c]:=sig + sig:=[['Union,b,'"failed"],:c] + mm:=[[x,:sig],[pred',:y],:z] + else if pred = 'partial then + [b,:c]:=sig + sig:=[['Union,b,'"failed"],:c] + mm:=[[x,:sig],y,:z] + mm' := EQSUBSTLIST('(m n p q r s t i j k l), + MSORT listOfPredOfTypePatternIds pred,mm) + EQSUBSTLIST('(D D1 D2 D3 D4 D5 D6 D7 D8 D9 D10 D11 D12 D13 D14), + MSORT listOfPatternIds [sig,[pred,:y]],mm') + +listOfPredOfTypePatternIds p == + p is ['AND,:lp] or p is ['OR,:lp] => + UNIONQ([:listOfPredOfTypePatternIds p1 for p1 in lp],NIL) + p is [op,a,.] and op = 'ofType => + isPatternVar a => [a] + nil + nil + +removeIsDomains pred == + pred is ['isDomain,a,b] => true + pred is ['AND,:predl] => + MKPF([x for x in predl | x isnt ['isDomain,:.]],'AND) + pred + +canRemoveIsDomain? pred == + -- returns nil OR an alist for substitutions of domains ordered so that + -- after substituting for each pair in turn, no left-hand names remain + alist := + pred is ['isDomain,a,b] => [[a,:b],:alist] + pred is ['AND,:predl] => + [[a,:b] for pred in predl | pred is ['isDomain,a,b]] + findSubstitutionOrder? alist + +findSubstitutionOrder? alist == fn(alist,nil) where + -- returns NIL or an appropriate substituion order + fn(alist,res) == + null alist => NREVERSE res + choice := or/[x for (x:=[a,:b]) in alist | null containedRight(a,alist)] => + fn(delete(choice,alist),[choice,:res]) + nil + +containedRight(x,alist)== or/[CONTAINED(x,y) for [.,:y] in alist] + +removeIsDomainD pred == + pred is ['isDomain,'D,D] => + [D,nil] + pred is ['AND,:preds] => + D := nil + for p in preds while not D repeat + p is ['isDomain,'D,D1] => + D := D1 + npreds := delete(['isDomain,'D,D1],preds) + D => + 1 = #npreds => [D,first npreds] + [D,['AND,:npreds]] + nil + nil + +formatModemap modemap == + [[dc,target,:sl],pred,:.]:= modemap + if alist := canRemoveIsDomain? pred then + dc:= substInOrder(alist,dc) + pred:= substInOrder(alist,removeIsDomains pred) + target:= substInOrder(alist,target) + sl:= substInOrder(alist,sl) + else if removeIsDomainD pred is [D,npred] then + pred := SUBST(D,'D,npred) + target := SUBST(D,'D,target) + sl := SUBST(D,'D,sl) + predPart:= formatIf pred + targetPart:= prefix2String target + argTypeList:= + null sl => nil + concat(prefix2String first sl,fn(rest sl)) where + fn l == + null l => nil + concat(",",prefix2String first l,fn rest l) + argPart:= + #sl<2 => argTypeList + ['"_(",:argTypeList,'"_)"] + fromPart:= + if dc = 'D and D + then concat('%b,'"from",'%d,prefix2String D) + else concat('%b,'"from",'%d,prefix2String dc) + firstPart:= concat('" ",argPart,'" -> ",targetPart) + sayWidth firstPart + sayWidth fromPart > 74 => --allow 5 spaces for " [n]" + fromPart:= concat('" ",fromPart) + secondPart := + sayWidth fromPart + sayWidth predPart < 75 => + concat(fromPart,predPart) + concat(fromPart,'%l,predPart) + concat(firstPart,'%l,secondPart) + firstPart:= concat(firstPart,fromPart) + sayWidth firstPart + sayWidth predPart < 80 => + concat(firstPart,predPart) + concat(firstPart,'%l,predPart) + +substInOrder(alist,x) == + alist is [[a,:b],:y] => substInOrder(y,SUBST(b,a,x)) + x + +reportOpSymbol op1 == + op := (STRINGP op1 => INTERN op1; op1) + modemaps := getAllModemapsFromDatabase(op,nil) + null modemaps => + ok := true + sayKeyedMsg("S2IF0010",[op1]) + if SIZE PNAME op1 < 3 then + x := UPCASE queryUserKeyedMsg("S2IZ0060",[op1]) + null MEMQ(STRING2ID_-N(x,1),'(Y YES)) => + ok := nil + sayKeyedMsg("S2IZ0061",[op1]) + ok => apropos [op1] + sayNewLine() + -- filter modemaps on whether they are exposed + mmsE := mmsU := NIL + for mm in modemaps repeat + isFreeFunctionFromMm(mm) or isExposedConstructor getDomainFromMm(mm) => mmsE := [mm,:mmsE] + mmsU := [mm,:mmsU] + if mmsE then + sayMms(op,mmsE,'"exposed") + if mmsU then + if mmsE then sayNewLine() + sayMms(op,mmsU,'"unexposed") + nil + where + sayMms(op,mms,label) == + m := # mms + sayMSG + m = 1 => + ['"There is one",:bright label,'"function called", + :bright op,'":"] + ['"There are ",m,:bright label,'"functions called", + :bright op,'":"] + for mm in mms for i in 1.. repeat + sayModemapWithNumber(mm,i) + +formatOpType (form:=[op,:argl]) == + null argl => unabbrev op + form2String [unabbrev op, :argl] + +formatOperationAlistEntry (entry:= [op,:modemaps]) == + -- alist has entries of the form: ((op sig) . pred) + -- opsig on this list => op is defined only when the predicate is true + ans:= nil + for [sig,.,:predtail] in modemaps repeat + pred := (predtail is [p,:.] => p; 'T) + -- operation is always defined + ans := + [concat(formatOpSignature(op,sig),formatIf pred),:ans] + ans + +formatOperation([[op,sig],.,[fn,.,n]],domain) == + opSigString := formatOpSignature(op,sig) + INTEGERP n and function Undef = KAR domain.n => + if INTEGERP $commentedOps then $commentedOps := $commentedOps + 1 + concat(" --",opSigString) + opSigString + +formatOpSignature(op,sig) == + concat('%b,formatOpSymbol(op,sig),'%d,": ",formatSignature sig) + +formatOpConstant op == + concat('%b,formatOpSymbol(op,'($)),'%d,'": constant") + +formatOpSymbol(op,sig) == + if op = 'Zero then op := "0" + else if op = 'One then op := "1" + null sig => op + quad := specialChar 'quad + n := #sig + (op = 'elt) and (n = 3) => + (CADR(sig) = '_$) => + STRINGP (sel := CADDR(sig)) => + [quad,".",sel] + [quad,".",quad] + op + STRINGP op or GET(op,"Led") or GET(op,"Nud") => + n = 3 => + if op = 'SEGMENT then op := '".." + op = 'in => [quad,'" ",op,'" ",quad] +-- stop exquo from being displayed as infix (since it is not accepted +-- as such by the interpreter) + op = 'exquo => op + [quad,op,quad] + n = 2 => + not GET(op,"Nud") => [quad,op] + [op,quad] + op + op + +formatAttribute x == + atom x => [" ",x] + x is [op,:argl] => + for x in argl repeat + argPart:= NCONC(argPart,concat(",",formatAttributeArg x)) + argPart => concat(" ",op,"_(",rest argPart,"_)") + [" ",op] + +formatAttributeArg x == + STRINGP x and x ='"*" => "_"*_"" + atom x => formatOpSymbol (x,nil) + x is [":",op,["Mapping",:sig]] => + concat('%b,formatOpSymbol(op,sig),": ",'%d,formatMapping sig) + prefix2String0 x + +formatMapping sig == + "STRCONC"/concat("Mapping(",formatSignature sig,")") + +dollarPercentTran x == + -- Translate $ to %. We actually return %% so that the message + -- printer will display a single % + x is [y,:z] => + y1 := dollarPercentTran y + z1 := dollarPercentTran z + EQ(y, y1) and EQ(z, z1) => x + [y1, :z1] + x = "$" or x = '"$" => "%%" + x + +formatSignatureAsTeX sig == + $formatSigAsTeX: local := 2 + formatSignature0 sig + +formatSignature sig == + $formatSigAsTeX: local := 1 + formatSignature0 sig + +formatSignatureArgs sml == + $formatSigAsTeX: local := 1 + formatSignatureArgs0 sml + +formatSignature0 sig == + null sig => "() -> ()" + INTEGERP sig => '"hashcode" + [tm,:sml] := sig + sourcePart:= formatSignatureArgs0 sml + targetPart:= prefix2String0 tm + dollarPercentTran concat(sourcePart,concat(" -> ",targetPart)) + +formatSignatureArgs0(sml) == +-- formats the arguments of a signature + null sml => ["_(_)"] + null rest sml => prefix2String0 first sml + argList:= prefix2String0 first sml + for m in rest sml repeat + argList:= concat(argList,concat(",",prefix2String0 m)) + concat("_(",concat(argList,"_)")) + +--% Conversions to string form + +expr2String x == + atom (u:= prefix2String0 x) => u + "STRCONC"/[atom2String y for y in u] + +-- exports (this is a badly named bit of sillyness) +prefix2StringAsTeX form == + form2StringAsTeX form + +prefix2String form == + form2String form + +-- local version +prefix2String0 form == + form2StringLocal form + +-- SUBRP form => formWrapId BPINAME form +-- atom form => +-- form=$EmptyMode or form=$quadSymbol => formWrapId specialChar 'quad +-- STRINGP form => formWrapId form +-- IDENTP form => +-- constructor? form => app2StringWrap(formWrapId form, [form]) +-- formWrapId form +-- formWrapId STRINGIMAGE form + +form2StringWithWhere u == + $permitWhere : local := true + $whereList: local := nil + s:= form2String u + $whereList => concat(s,'%b,'"where",'%d,"%i",$whereList,"%u") + s + +form2StringWithPrens form == + null (argl := rest form) => [first form] + null rest argl => [first form,"(",first argl,")"] + form2String form + +formString u == + x := form2String u + atom x => STRINGIMAGE x + "STRCONC"/[STRINGIMAGE y for y in x] + +form2String u == + $formatSigAsTeX: local := 1 + form2StringLocal u + +form2StringAsTeX u == + $formatSigAsTeX: local := 2 + form2StringLocal u + +form2StringLocal u == +--+ + $NRTmonitorIfTrue : local := nil + $fortInts2Floats : local := nil + form2String1 u + +constructorName con == + $abbreviateTypes => abbreviate con + con + +form2String1 u == + ATOM u => + u=$EmptyMode or u=$quadSymbol => formWrapId specialChar 'quad + IDENTP u => + constructor? u => app2StringWrap(formWrapId u, [u]) + u + SUBRP u => formWrapId BPINAME u + STRINGP u => formWrapId u + WRITE_-TO_-STRING formWrapId u + u1 := u + op := CAR u + argl := CDR u + op='Join or op= 'mkCategory => formJoin1(op,argl) + $InteractiveMode and (u:= constructor? op) => + null argl => app2StringWrap(formWrapId constructorName op, u1) + op = "NTuple" => [ form2String1 first argl, "*"] + op = "Map" => ["(",:formatSignature0 [argl.1,argl.0],")"] + op = 'Record => record2String(argl) + null (conSig := getConstructorSignature op) => + application2String(constructorName op,[form2String1(a) for a in argl], u1) + ml := rest conSig + if not freeOfSharpVars ml then + ml:=SUBLIS([[pvar,:val] for pvar in $FormalMapVariableList + for val in argl], ml) + argl:= formArguments2String(argl,ml) + -- extra null check to handle mutable domain hack. + null argl => constructorName op + application2String(constructorName op,argl, u1) + op = "Mapping" => ["(",:formatSignature argl,")"] + op = "Record" => record2String(argl) + op = 'Union => + application2String(op,[form2String1 x for x in argl], u1) + op = ":" => + null argl => [ '":" ] + null rest argl => [ '":", form2String1 first argl ] + formDecl2String(argl.0,argl.1) + op = "#" and PAIRP argl and LISTP CAR argl => + STRINGIMAGE SIZE CAR argl + op = 'Join => formJoin2String argl + op = "ATTRIBUTE" => form2String1 first argl + op='Zero => 0 + op='One => 1 + op = 'AGGLST => tuple2String argl + op = 'BRACKET => + argl' := form2String1 first argl + ["[",:(atom argl' => [argl']; argl'),"]"] + op = "SIGNATURE" => + [operation,sig] := argl + concat(operation,": ",formatSignature sig) + op = 'COLLECT => formCollect2String argl + op = 'construct => + concat(lbrkSch(), + tuple2String [form2String1 x for x in argl],rbrkSch()) + op = "SEGMENT" => + null argl => '".." + lo := form2String1 first argl + argl := rest argl + (null argl) or null (first argl) => [lo, '".."] + [lo, '"..", form2String1 first argl] + isBinaryInfix op => fortexp0 [op,:argl] + -- COMPILED_-FUNCTION_-P(op) => form2String1 coerceMap2E(u1,NIL) + application2String(op,[form2String1 x for x in argl], u1) + +formWrapId id == + $formatSigAsTeX = 1 => id + $formatSigAsTeX = 2 => + sep := '"`" + FORMAT(NIL,'"\verb~a~a~a",sep, id, sep) + error "Bad formatSigValue" + +formArguments2String(argl,ml) == [fn(x,m) for x in argl for m in ml] where + fn(x,m) == + x=$EmptyMode or x=$quadSymbol => specialChar 'quad + STRINGP(x) or IDENTP(x) => x + x is [ ='_:,:.] => form2String1 x + isValidType(m) and PAIRP(m) and + (GETDATABASE(first(m),'CONSTRUCTORKIND) = 'domain) => + (x' := coerceInteractive(objNewWrap(x,m),$OutputForm)) => + form2String1 objValUnwrap x' + form2String1 x + form2String1 x + +formDecl2String(left,right) == + $declVar: local := left + whereBefore := $whereList + ls:= form2StringLocal left + rs:= form2StringLocal right + NE($whereList,whereBefore) and $permitWhere => ls + concat(form2StringLocal ls,'": ",rs) + +formJoin1(op,u) == + if op = 'Join then [:argl,last] := u else (argl := nil; last := [op,:u]) + last is [id,.,:r] and id in '(mkCategory CATEGORY) => + $abbreviateJoin = true => concat(formJoin2 argl,'%b,'"with",'%d,'"...") + $permitWhere = true => + opList:= formatJoinKey(r,id) + $whereList:= concat($whereList,"%l",$declVar,": ", + formJoin2 argl,'%b,'"with",'%d,"%i",opList,"%u") + formJoin2 argl + opList:= formatJoinKey(r,id) + suffix := concat('%b,'"with",'%d,"%i",opList,"%u") + concat(formJoin2 argl,suffix) + formJoin2 u + +formatJoinKey(r,key) == + key = 'mkCategory => + r is [opPart,catPart,:.] => + opString := + opPart is [='LIST,:u] => + "append"/[concat("%l",formatOpSignature(op,sig),formatIf pred) + for [='QUOTE,[[op,sig],pred]] in u] + nil + catString := + catPart is [='LIST,:u] => + "append"/[concat("%l",'" ",form2StringLocal con,formatIf pred) + for [='QUOTE,[con,pred]] in u] + nil + concat(opString,catString) + '"?? unknown mkCategory format ??" + -- otherwise we have the CATEGORY form + "append"/[fn for x in r] where fn() == + x is ['SIGNATURE,op,sig] => concat("%l",formatOpSignature(op,sig)) + x is ['ATTRIBUTE,a] => concat("%l",formatAttribute a) + x + +formJoin2 argl == +-- argl is a list of categories NOT containing a "with" + null argl => '"" + 1=#argl => form2StringLocal argl.0 + application2String('Join,[form2StringLocal x for x in argl], NIL) + +formJoin2String (u:=[:argl,last]) == + last is ["CATEGORY",.,:atsigList] => + postString:= concat("_(",formTuple2String atsigList,"_)") + #argl=1 => concat(first argl,'" with ",postString) + concat(application2String('Join,argl, NIL)," with ",postString) + application2String('Join,u, NIL) + +formCollect2String [:itl,body] == + ["_(",body,:"append"/[formIterator2String x for x in itl],"_)"] + +formIterator2String x == + x is ["STEP",y,s,.,:l] => + tail:= (l is [f] => form2StringLocal f; nil) + concat("for ",y," in ",s,'"..",tail) + x is ["tails",y] => concat("tails ",formatIterator y) + x is ["reverse",y] => concat("reverse ",formatIterator y) + x is ["|",y,p] => concat(formatIterator y," | ",form2StringLocal p) + x is ["until",p] => concat("until ",form2StringLocal p) + x is ["while",p] => concat("while ",form2StringLocal p) + systemErrorHere "formatIterator" + +tuple2String argl == + null argl => nil + string := first argl + if string in '("failed" "nil" "prime" "sqfr" "irred") + then string := STRCONC('"_"",string,'"_"") + else string := + ATOM string => object2String string + [f x for x in string] + for x in rest argl repeat + if x in '("failed" "nil" "prime" "sqfr" "irred") then + x := STRCONC('"_"",x,'"_"") + string:= concat(string,concat(",",f x)) + string + where + f x == + ATOM x => object2String x + -- [f CAR x,:f CDR x] + [f y for y in x] + +script2String s == + null s => '"" -- just to be safe + if not PAIRP s then s := [s] + linearFormatForm(CAR s, CDR s) + +linearFormatName x == + atom x => x + linearFormat x + +linearFormat x == + atom x => x + x is [op,:argl] and atom op => + argPart:= + argl is [a,:l] => [a,:"append"/[[",",x] for x in l]] + nil + [op,"(",:argPart,")"] + [linearFormat y for y in x] + +numOfSpadArguments id == + char("*") = (s:= PNAME id).0 => + +/[n for i in 1.. while INTEGERP (n:=PARSE_-INTEGER PNAME s.i)] + keyedSystemError("S2IF0012",[id]) + +linearFormatForm(op,argl) == + s:= PNAME op + indexList:= [PARSE_-INTEGER PNAME d for i in 1.. while + (DIGITP (d:= s.(maxIndex:= i)))] + cleanOp:= INTERN ("STRCONC"/[PNAME s.i for i in maxIndex..MAXINDEX s]) + fnArgs:= + indexList.0 > 0 => + concat('"(",formatArgList take(-indexList.0,argl),'")") + nil + if #indexList > 1 then + scriptArgs:= formatArgList take(indexList.1,argl) + argl := drop(indexList.1,argl) + for i in rest rest indexList repeat + subArglist:= take(i,argl) + argl:= drop(i,argl) + scriptArgs:= concat(scriptArgs,";",formatArgList subArglist) + scriptArgs:= + scriptArgs => concat(specialChar 'lbrk,scriptArgs, specialChar 'rbrk) + nil + l := [(STRINGP f => f; STRINGIMAGE f) for f in + concat(cleanOp,scriptArgs,fnArgs)] + "STRCONC"/l + +formatArgList l == + null l => nil + acc:= linearFormat first l + for x in rest l repeat + acc:= concat(acc,",",linearFormat x) + acc + +formTuple2String argl == + null argl => nil + string:= form2StringLocal first argl + for x in rest argl repeat + string:= concat(string,concat(",",form2StringLocal x)) + string + +isInternalFunctionName(op) == + (not IDENTP(op)) or (op = "*") or (op = "**") => NIL + (1 = SIZE(op':= PNAME op)) or (char("*") ^= op'.0) => NIL + -- if there is a semicolon in the name then it is the name of + -- a compiled spad function + null (e := STRPOS('"_;",op',1,NIL)) => NIL + (char(" ") = (y := op'.1)) or (char("*") = y) => NIL + table := MAKETRTTABLE('"0123456789",NIL) + s := STRPOSL(table,op',1,true) + null(s) or s > e => NIL + SUBSTRING(op',s,e-s) + +application2String(op,argl, linkInfo) == + null argl => + (op' := isInternalFunctionName(op)) => op' + app2StringWrap(formWrapId op, linkInfo) + 1=#argl => + first argl is ["<",:.] => concat(op,first argl) + concat(app2StringWrap(formWrapId op, linkInfo)," ",first argl) +--op in '(UP SM) => +-- newop:= (op = "UP" => "P";"M") +-- concat(newop,concat(lbrkSch(),argl.0,rbrkSch(),argl.1)) +--op='RM =>concat("M",concat(lbrkSch(), +-- argl.0,",",argl.1,rbrkSch(),argl.2)) +--op='MP =>concat("P",concat(argl.0,argl.1)) + op='SEGMENT => + null argl => '".." + (null rest argl) or (null first rest argl) => + concat(first argl, '"..") + concat(first argl, concat('"..", first rest argl)) + concat(app2StringWrap(formWrapId op, linkInfo) , + concat("_(",concat(tuple2String argl,"_)"))) + +app2StringConcat0(x,y) == + FORMAT(NIL, '"~a ~a", x, y) + +app2StringWrap(string, linkInfo) == + not linkInfo => string + $formatSigAsTeX = 1 => string + $formatSigAsTeX = 2 => + str2 := "app2StringConcat0"/form2Fence linkInfo + sep := '"`" + FORMAT(NIL, '"\lispLink{\verb!(|conPage| '~a)!}{~a}", + str2, string) + error "Bad value for $formatSigAsTeX" + +record2String x == + argPart := NIL + for [":",a,b] in x repeat argPart:= + concat(argPart,",",a,": ",form2StringLocal b) + null argPart => '"Record()" + concat("Record_(",rest argPart,"_)") + +plural(n,string) == + suffix:= + n = 1 => '"" + '"s" + [:bright n,string,suffix] + +formatIf pred == + not pred => nil + pred in '(T (QUOTE T)) => nil + concat('%b,'"if",'%d,pred2English pred) + +formatPredParts s == + s is ['QUOTE,s1] => formatPredParts s1 + s is ['LIST,:s1] => [formatPredParts s2 for s2 in s1] + s is ['devaluate,s1] => formatPredParts s1 + s is ['getDomainView,s1,.] => formatPredParts s1 + s is ['SUBST,a,b,c] => -- this is a signature + s1 := formatPredParts SUBST(formatPredParts a,b,c) + s1 isnt [fun,sig] => s1 + ['SIGNATURE,fun,[formatPredParts(r) for r in sig]] + s + +pred2English x == + x is ['IF,cond,thenClause,elseClause] => + c := concat('"if ",pred2English cond) + t := concat('" then ",pred2English thenClause) + e := concat('" else ",pred2English elseClause) + concat(c,t,e) + x is ['AND,:l] => + tail:="append"/[concat(bright '"and",pred2English x) for x in rest l] + concat(pred2English first l,tail) + x is ['OR,:l] => + tail:= "append"/[concat(bright '"or",pred2English x) for x in rest l] + concat(pred2English first l,tail) + x is ['NOT,l] => + concat('"not ",pred2English l) + x is [op,a,b] and op in '(has ofCategory) => + concat(pred2English a,'%b,'"has",'%d,form2String abbreviate b) + x is [op,a,b] and op in '(HasSignature HasAttribute HasCategory) => + concat(prefix2String0 formatPredParts a,'%b,'"has",'%d, + prefix2String0 formatPredParts b) + x is [op,a,b] and op in '(ofType getDomainView) => + if b is ['QUOTE,b'] then b := b' + concat(pred2English a,'": ",form2String abbreviate b) + x is [op,a,b] and op in '(isDomain domainEqual) => + concat(pred2English a,'" = ",form2String abbreviate b) + x is [op,:.] and (translation := LASSOC(op,'( + (_< . " < ") (_<_= . " <= ") + (_> . " > ") (_>_= . " >= ") (_= . " = ") (_^_= . " _^_= ")))) => + concat(pred2English a,translation,pred2English b) + x is ['ATTRIBUTE,form] => + concat("attribute: ",form2String form) + form2String x + +object2String x == + STRINGP x => x + IDENTP x => PNAME x + NULL x => '"" + PAIRP x => STRCONC(object2String first x, object2String rest x) + WRITE_-TO_-STRING x + +object2Identifier x == + IDENTP x => x + STRINGP x => INTERN x + INTERN WRITE_-TO_-STRING x + +blankList x == "append"/[[BLANK,y] for y in x] +--------------------> NEW DEFINITION (see cformat.boot.pamphlet) +pkey keyStuff == + if not PAIRP keyStuff then keyStuff := [keyStuff] + allMsgs := ['" "] + while not null keyStuff repeat + dbN := NIL + argL := NIL + key := first keyStuff + keyStuff := IFCDR keyStuff + next := IFCAR keyStuff + while PAIRP next repeat + if CAR next = 'dbN then dbN := CADR next + else argL := next + keyStuff := IFCDR keyStuff + next := IFCAR keyStuff + oneMsg := returnStLFromKey(key,argL,dbN) + allMsgs := ['" ", :NCONC (oneMsg,allMsgs)] + allMsgs + +string2Float s == + -- takes a string, calls the parser on it and returns a float object + p := ncParseFromString s + p isnt [["$elt", FloatDomain, "float"], x, y, z] => + systemError '"string2Float: did not get a float expression" + flt := getFunctionFromDomain("float", FloatDomain, + [$Integer, $Integer, $PositiveInteger]) + SPADCALL(x, y, z, flt) + + + +form2Fence form == + -- body of dbMkEvalable + [op, :.] := form + kind := GETDATABASE(op,'CONSTRUCTORKIND) + kind = 'category => form2Fence1 form + form2Fence1 mkEvalable form + +form2Fence1 x == + x is [op,:argl] => + op = 'QUOTE => ['"(QUOTE ",:form2FenceQuote first argl,'")"] + ['"(", FORMAT(NIL, '"|~a|", op),:"append"/[form2Fence1 y for y in argl],'")"] + IDENTP x => FORMAT(NIL, '"|~a|", x) +-- [x] + ['" ", x] + +form2FenceQuote x == + NUMBERP x => [STRINGIMAGE x] + SYMBOLP x => [FORMAT(NIL, '"|~a|", x)] + atom x => '"??" + ['"(",:form2FenceQuote first x,:form2FenceQuoteTail rest x] + +form2FenceQuoteTail x == + null x => ['")"] + atom x => ['" . ",:form2FenceQuote x,'")"] + ['" ",:form2FenceQuote first x,:form2FenceQuoteTail rest x] + +form2StringList u == + atom (r := form2String u) => [r] + r diff --git a/src/interp/format.boot.pamphlet b/src/interp/format.boot.pamphlet deleted file mode 100644 index 5f8da182..00000000 --- a/src/interp/format.boot.pamphlet +++ /dev/null @@ -1,807 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp format.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\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. - -@ -<<*>>= -<> - -import '"macros" -)package "BOOT" - ---% Functions for display formatting system objects - --- some of these are redundant and should be compacted -$formatSigAsTeX := 1 - ---% Formatting modemaps - -sayModemap m == - -- sayMSG formatModemap displayTranModemap m - sayMSG formatModemap old2NewModemaps displayTranModemap m - -sayModemapWithNumber(m,n) == - msg := reverse cleanUpSegmentedMsg reverse ["%i","%i",'" ", - STRCONC(lbrkSch(),object2String n,rbrkSch()), - :formatModemap displayTranModemap m,"%u","%u"] - sayMSG flowSegmentedMsg(reverse msg,$LINELENGTH,3) - -displayOpModemaps(op,modemaps) == - TERPRI() - count:= #modemaps - phrase:= (count=1 => 'modemap;'modemaps) - sayMSG ['%b,count,'%d,phrase,'" for",'%b,op,'%d,'":"] - for modemap in modemaps repeat sayModemap modemap - -displayTranModemap (mm is [[x,:sig],[pred,:y],:z]) == - -- The next 8 lines are a HACK to deal with the "partial" definition - -- JHD/RSS - if pred is ['partial,:pred'] then - [b,:c]:=sig - sig:=[['Union,b,'"failed"],:c] - mm:=[[x,:sig],[pred',:y],:z] - else if pred = 'partial then - [b,:c]:=sig - sig:=[['Union,b,'"failed"],:c] - mm:=[[x,:sig],y,:z] - mm' := EQSUBSTLIST('(m n p q r s t i j k l), - MSORT listOfPredOfTypePatternIds pred,mm) - EQSUBSTLIST('(D D1 D2 D3 D4 D5 D6 D7 D8 D9 D10 D11 D12 D13 D14), - MSORT listOfPatternIds [sig,[pred,:y]],mm') - -listOfPredOfTypePatternIds p == - p is ['AND,:lp] or p is ['OR,:lp] => - UNIONQ([:listOfPredOfTypePatternIds p1 for p1 in lp],NIL) - p is [op,a,.] and op = 'ofType => - isPatternVar a => [a] - nil - nil - -removeIsDomains pred == - pred is ['isDomain,a,b] => true - pred is ['AND,:predl] => - MKPF([x for x in predl | x isnt ['isDomain,:.]],'AND) - pred - -canRemoveIsDomain? pred == - -- returns nil OR an alist for substitutions of domains ordered so that - -- after substituting for each pair in turn, no left-hand names remain - alist := - pred is ['isDomain,a,b] => [[a,:b],:alist] - pred is ['AND,:predl] => - [[a,:b] for pred in predl | pred is ['isDomain,a,b]] - findSubstitutionOrder? alist - -findSubstitutionOrder? alist == fn(alist,nil) where - -- returns NIL or an appropriate substituion order - fn(alist,res) == - null alist => NREVERSE res - choice := or/[x for (x:=[a,:b]) in alist | null containedRight(a,alist)] => - fn(delete(choice,alist),[choice,:res]) - nil - -containedRight(x,alist)== or/[CONTAINED(x,y) for [.,:y] in alist] - -removeIsDomainD pred == - pred is ['isDomain,'D,D] => - [D,nil] - pred is ['AND,:preds] => - D := nil - for p in preds while not D repeat - p is ['isDomain,'D,D1] => - D := D1 - npreds := delete(['isDomain,'D,D1],preds) - D => - 1 = #npreds => [D,first npreds] - [D,['AND,:npreds]] - nil - nil - -formatModemap modemap == - [[dc,target,:sl],pred,:.]:= modemap - if alist := canRemoveIsDomain? pred then - dc:= substInOrder(alist,dc) - pred:= substInOrder(alist,removeIsDomains pred) - target:= substInOrder(alist,target) - sl:= substInOrder(alist,sl) - else if removeIsDomainD pred is [D,npred] then - pred := SUBST(D,'D,npred) - target := SUBST(D,'D,target) - sl := SUBST(D,'D,sl) - predPart:= formatIf pred - targetPart:= prefix2String target - argTypeList:= - null sl => nil - concat(prefix2String first sl,fn(rest sl)) where - fn l == - null l => nil - concat(",",prefix2String first l,fn rest l) - argPart:= - #sl<2 => argTypeList - ['"_(",:argTypeList,'"_)"] - fromPart:= - if dc = 'D and D - then concat('%b,'"from",'%d,prefix2String D) - else concat('%b,'"from",'%d,prefix2String dc) - firstPart:= concat('" ",argPart,'" -> ",targetPart) - sayWidth firstPart + sayWidth fromPart > 74 => --allow 5 spaces for " [n]" - fromPart:= concat('" ",fromPart) - secondPart := - sayWidth fromPart + sayWidth predPart < 75 => - concat(fromPart,predPart) - concat(fromPart,'%l,predPart) - concat(firstPart,'%l,secondPart) - firstPart:= concat(firstPart,fromPart) - sayWidth firstPart + sayWidth predPart < 80 => - concat(firstPart,predPart) - concat(firstPart,'%l,predPart) - -substInOrder(alist,x) == - alist is [[a,:b],:y] => substInOrder(y,SUBST(b,a,x)) - x - -reportOpSymbol op1 == - op := (STRINGP op1 => INTERN op1; op1) - modemaps := getAllModemapsFromDatabase(op,nil) - null modemaps => - ok := true - sayKeyedMsg("S2IF0010",[op1]) - if SIZE PNAME op1 < 3 then - x := UPCASE queryUserKeyedMsg("S2IZ0060",[op1]) - null MEMQ(STRING2ID_-N(x,1),'(Y YES)) => - ok := nil - sayKeyedMsg("S2IZ0061",[op1]) - ok => apropos [op1] - sayNewLine() - -- filter modemaps on whether they are exposed - mmsE := mmsU := NIL - for mm in modemaps repeat - isFreeFunctionFromMm(mm) or isExposedConstructor getDomainFromMm(mm) => mmsE := [mm,:mmsE] - mmsU := [mm,:mmsU] - if mmsE then - sayMms(op,mmsE,'"exposed") - if mmsU then - if mmsE then sayNewLine() - sayMms(op,mmsU,'"unexposed") - nil - where - sayMms(op,mms,label) == - m := # mms - sayMSG - m = 1 => - ['"There is one",:bright label,'"function called", - :bright op,'":"] - ['"There are ",m,:bright label,'"functions called", - :bright op,'":"] - for mm in mms for i in 1.. repeat - sayModemapWithNumber(mm,i) - -formatOpType (form:=[op,:argl]) == - null argl => unabbrev op - form2String [unabbrev op, :argl] - -formatOperationAlistEntry (entry:= [op,:modemaps]) == - -- alist has entries of the form: ((op sig) . pred) - -- opsig on this list => op is defined only when the predicate is true - ans:= nil - for [sig,.,:predtail] in modemaps repeat - pred := (predtail is [p,:.] => p; 'T) - -- operation is always defined - ans := - [concat(formatOpSignature(op,sig),formatIf pred),:ans] - ans - -formatOperation([[op,sig],.,[fn,.,n]],domain) == - opSigString := formatOpSignature(op,sig) - INTEGERP n and function Undef = KAR domain.n => - if INTEGERP $commentedOps then $commentedOps := $commentedOps + 1 - concat(" --",opSigString) - opSigString - -formatOpSignature(op,sig) == - concat('%b,formatOpSymbol(op,sig),'%d,": ",formatSignature sig) - -formatOpConstant op == - concat('%b,formatOpSymbol(op,'($)),'%d,'": constant") - -formatOpSymbol(op,sig) == - if op = 'Zero then op := "0" - else if op = 'One then op := "1" - null sig => op - quad := specialChar 'quad - n := #sig - (op = 'elt) and (n = 3) => - (CADR(sig) = '_$) => - STRINGP (sel := CADDR(sig)) => - [quad,".",sel] - [quad,".",quad] - op - STRINGP op or GET(op,"Led") or GET(op,"Nud") => - n = 3 => - if op = 'SEGMENT then op := '".." - op = 'in => [quad,'" ",op,'" ",quad] --- stop exquo from being displayed as infix (since it is not accepted --- as such by the interpreter) - op = 'exquo => op - [quad,op,quad] - n = 2 => - not GET(op,"Nud") => [quad,op] - [op,quad] - op - op - -formatAttribute x == - atom x => [" ",x] - x is [op,:argl] => - for x in argl repeat - argPart:= NCONC(argPart,concat(",",formatAttributeArg x)) - argPart => concat(" ",op,"_(",rest argPart,"_)") - [" ",op] - -formatAttributeArg x == - STRINGP x and x ='"*" => "_"*_"" - atom x => formatOpSymbol (x,nil) - x is [":",op,["Mapping",:sig]] => - concat('%b,formatOpSymbol(op,sig),": ",'%d,formatMapping sig) - prefix2String0 x - -formatMapping sig == - "STRCONC"/concat("Mapping(",formatSignature sig,")") - -dollarPercentTran x == - -- Translate $ to %. We actually return %% so that the message - -- printer will display a single % - x is [y,:z] => - y1 := dollarPercentTran y - z1 := dollarPercentTran z - EQ(y, y1) and EQ(z, z1) => x - [y1, :z1] - x = "$" or x = '"$" => "%%" - x - -formatSignatureAsTeX sig == - $formatSigAsTeX: local := 2 - formatSignature0 sig - -formatSignature sig == - $formatSigAsTeX: local := 1 - formatSignature0 sig - -formatSignatureArgs sml == - $formatSigAsTeX: local := 1 - formatSignatureArgs0 sml - -formatSignature0 sig == - null sig => "() -> ()" - INTEGERP sig => '"hashcode" - [tm,:sml] := sig - sourcePart:= formatSignatureArgs0 sml - targetPart:= prefix2String0 tm - dollarPercentTran concat(sourcePart,concat(" -> ",targetPart)) - -formatSignatureArgs0(sml) == --- formats the arguments of a signature - null sml => ["_(_)"] - null rest sml => prefix2String0 first sml - argList:= prefix2String0 first sml - for m in rest sml repeat - argList:= concat(argList,concat(",",prefix2String0 m)) - concat("_(",concat(argList,"_)")) - ---% Conversions to string form - -expr2String x == - atom (u:= prefix2String0 x) => u - "STRCONC"/[atom2String y for y in u] - --- exports (this is a badly named bit of sillyness) -prefix2StringAsTeX form == - form2StringAsTeX form - -prefix2String form == - form2String form - --- local version -prefix2String0 form == - form2StringLocal form - --- SUBRP form => formWrapId BPINAME form --- atom form => --- form=$EmptyMode or form=$quadSymbol => formWrapId specialChar 'quad --- STRINGP form => formWrapId form --- IDENTP form => --- constructor? form => app2StringWrap(formWrapId form, [form]) --- formWrapId form --- formWrapId STRINGIMAGE form - -form2StringWithWhere u == - $permitWhere : local := true - $whereList: local := nil - s:= form2String u - $whereList => concat(s,'%b,'"where",'%d,"%i",$whereList,"%u") - s - -form2StringWithPrens form == - null (argl := rest form) => [first form] - null rest argl => [first form,"(",first argl,")"] - form2String form - -formString u == - x := form2String u - atom x => STRINGIMAGE x - "STRCONC"/[STRINGIMAGE y for y in x] - -form2String u == - $formatSigAsTeX: local := 1 - form2StringLocal u - -form2StringAsTeX u == - $formatSigAsTeX: local := 2 - form2StringLocal u - -form2StringLocal u == ---+ - $NRTmonitorIfTrue : local := nil - $fortInts2Floats : local := nil - form2String1 u - -constructorName con == - $abbreviateTypes => abbreviate con - con - -form2String1 u == - ATOM u => - u=$EmptyMode or u=$quadSymbol => formWrapId specialChar 'quad - IDENTP u => - constructor? u => app2StringWrap(formWrapId u, [u]) - u - SUBRP u => formWrapId BPINAME u - STRINGP u => formWrapId u - WRITE_-TO_-STRING formWrapId u - u1 := u - op := CAR u - argl := CDR u - op='Join or op= 'mkCategory => formJoin1(op,argl) - $InteractiveMode and (u:= constructor? op) => - null argl => app2StringWrap(formWrapId constructorName op, u1) - op = "NTuple" => [ form2String1 first argl, "*"] - op = "Map" => ["(",:formatSignature0 [argl.1,argl.0],")"] - op = 'Record => record2String(argl) - null (conSig := getConstructorSignature op) => - application2String(constructorName op,[form2String1(a) for a in argl], u1) - ml := rest conSig - if not freeOfSharpVars ml then - ml:=SUBLIS([[pvar,:val] for pvar in $FormalMapVariableList - for val in argl], ml) - argl:= formArguments2String(argl,ml) - -- extra null check to handle mutable domain hack. - null argl => constructorName op - application2String(constructorName op,argl, u1) - op = "Mapping" => ["(",:formatSignature argl,")"] - op = "Record" => record2String(argl) - op = 'Union => - application2String(op,[form2String1 x for x in argl], u1) - op = ":" => - null argl => [ '":" ] - null rest argl => [ '":", form2String1 first argl ] - formDecl2String(argl.0,argl.1) - op = "#" and PAIRP argl and LISTP CAR argl => - STRINGIMAGE SIZE CAR argl - op = 'Join => formJoin2String argl - op = "ATTRIBUTE" => form2String1 first argl - op='Zero => 0 - op='One => 1 - op = 'AGGLST => tuple2String argl - op = 'BRACKET => - argl' := form2String1 first argl - ["[",:(atom argl' => [argl']; argl'),"]"] - op = "SIGNATURE" => - [operation,sig] := argl - concat(operation,": ",formatSignature sig) - op = 'COLLECT => formCollect2String argl - op = 'construct => - concat(lbrkSch(), - tuple2String [form2String1 x for x in argl],rbrkSch()) - op = "SEGMENT" => - null argl => '".." - lo := form2String1 first argl - argl := rest argl - (null argl) or null (first argl) => [lo, '".."] - [lo, '"..", form2String1 first argl] - isBinaryInfix op => fortexp0 [op,:argl] - -- COMPILED_-FUNCTION_-P(op) => form2String1 coerceMap2E(u1,NIL) - application2String(op,[form2String1 x for x in argl], u1) - -formWrapId id == - $formatSigAsTeX = 1 => id - $formatSigAsTeX = 2 => - sep := '"`" - FORMAT(NIL,'"\verb~a~a~a",sep, id, sep) - error "Bad formatSigValue" - -formArguments2String(argl,ml) == [fn(x,m) for x in argl for m in ml] where - fn(x,m) == - x=$EmptyMode or x=$quadSymbol => specialChar 'quad - STRINGP(x) or IDENTP(x) => x - x is [ ='_:,:.] => form2String1 x - isValidType(m) and PAIRP(m) and - (GETDATABASE(first(m),'CONSTRUCTORKIND) = 'domain) => - (x' := coerceInteractive(objNewWrap(x,m),$OutputForm)) => - form2String1 objValUnwrap x' - form2String1 x - form2String1 x - -formDecl2String(left,right) == - $declVar: local := left - whereBefore := $whereList - ls:= form2StringLocal left - rs:= form2StringLocal right - NE($whereList,whereBefore) and $permitWhere => ls - concat(form2StringLocal ls,'": ",rs) - -formJoin1(op,u) == - if op = 'Join then [:argl,last] := u else (argl := nil; last := [op,:u]) - last is [id,.,:r] and id in '(mkCategory CATEGORY) => - $abbreviateJoin = true => concat(formJoin2 argl,'%b,'"with",'%d,'"...") - $permitWhere = true => - opList:= formatJoinKey(r,id) - $whereList:= concat($whereList,"%l",$declVar,": ", - formJoin2 argl,'%b,'"with",'%d,"%i",opList,"%u") - formJoin2 argl - opList:= formatJoinKey(r,id) - suffix := concat('%b,'"with",'%d,"%i",opList,"%u") - concat(formJoin2 argl,suffix) - formJoin2 u - -formatJoinKey(r,key) == - key = 'mkCategory => - r is [opPart,catPart,:.] => - opString := - opPart is [='LIST,:u] => - "append"/[concat("%l",formatOpSignature(op,sig),formatIf pred) - for [='QUOTE,[[op,sig],pred]] in u] - nil - catString := - catPart is [='LIST,:u] => - "append"/[concat("%l",'" ",form2StringLocal con,formatIf pred) - for [='QUOTE,[con,pred]] in u] - nil - concat(opString,catString) - '"?? unknown mkCategory format ??" - -- otherwise we have the CATEGORY form - "append"/[fn for x in r] where fn() == - x is ['SIGNATURE,op,sig] => concat("%l",formatOpSignature(op,sig)) - x is ['ATTRIBUTE,a] => concat("%l",formatAttribute a) - x - -formJoin2 argl == --- argl is a list of categories NOT containing a "with" - null argl => '"" - 1=#argl => form2StringLocal argl.0 - application2String('Join,[form2StringLocal x for x in argl], NIL) - -formJoin2String (u:=[:argl,last]) == - last is ["CATEGORY",.,:atsigList] => - postString:= concat("_(",formTuple2String atsigList,"_)") - #argl=1 => concat(first argl,'" with ",postString) - concat(application2String('Join,argl, NIL)," with ",postString) - application2String('Join,u, NIL) - -formCollect2String [:itl,body] == - ["_(",body,:"append"/[formIterator2String x for x in itl],"_)"] - -formIterator2String x == - x is ["STEP",y,s,.,:l] => - tail:= (l is [f] => form2StringLocal f; nil) - concat("for ",y," in ",s,'"..",tail) - x is ["tails",y] => concat("tails ",formatIterator y) - x is ["reverse",y] => concat("reverse ",formatIterator y) - x is ["|",y,p] => concat(formatIterator y," | ",form2StringLocal p) - x is ["until",p] => concat("until ",form2StringLocal p) - x is ["while",p] => concat("while ",form2StringLocal p) - systemErrorHere "formatIterator" - -tuple2String argl == - null argl => nil - string := first argl - if string in '("failed" "nil" "prime" "sqfr" "irred") - then string := STRCONC('"_"",string,'"_"") - else string := - ATOM string => object2String string - [f x for x in string] - for x in rest argl repeat - if x in '("failed" "nil" "prime" "sqfr" "irred") then - x := STRCONC('"_"",x,'"_"") - string:= concat(string,concat(",",f x)) - string - where - f x == - ATOM x => object2String x - -- [f CAR x,:f CDR x] - [f y for y in x] - -script2String s == - null s => '"" -- just to be safe - if not PAIRP s then s := [s] - linearFormatForm(CAR s, CDR s) - -linearFormatName x == - atom x => x - linearFormat x - -linearFormat x == - atom x => x - x is [op,:argl] and atom op => - argPart:= - argl is [a,:l] => [a,:"append"/[[",",x] for x in l]] - nil - [op,"(",:argPart,")"] - [linearFormat y for y in x] - -numOfSpadArguments id == - char("*") = (s:= PNAME id).0 => - +/[n for i in 1.. while INTEGERP (n:=PARSE_-INTEGER PNAME s.i)] - keyedSystemError("S2IF0012",[id]) - -linearFormatForm(op,argl) == - s:= PNAME op - indexList:= [PARSE_-INTEGER PNAME d for i in 1.. while - (DIGITP (d:= s.(maxIndex:= i)))] - cleanOp:= INTERN ("STRCONC"/[PNAME s.i for i in maxIndex..MAXINDEX s]) - fnArgs:= - indexList.0 > 0 => - concat('"(",formatArgList take(-indexList.0,argl),'")") - nil - if #indexList > 1 then - scriptArgs:= formatArgList take(indexList.1,argl) - argl := drop(indexList.1,argl) - for i in rest rest indexList repeat - subArglist:= take(i,argl) - argl:= drop(i,argl) - scriptArgs:= concat(scriptArgs,";",formatArgList subArglist) - scriptArgs:= - scriptArgs => concat(specialChar 'lbrk,scriptArgs, specialChar 'rbrk) - nil - l := [(STRINGP f => f; STRINGIMAGE f) for f in - concat(cleanOp,scriptArgs,fnArgs)] - "STRCONC"/l - -formatArgList l == - null l => nil - acc:= linearFormat first l - for x in rest l repeat - acc:= concat(acc,",",linearFormat x) - acc - -formTuple2String argl == - null argl => nil - string:= form2StringLocal first argl - for x in rest argl repeat - string:= concat(string,concat(",",form2StringLocal x)) - string - -isInternalFunctionName(op) == - (not IDENTP(op)) or (op = "*") or (op = "**") => NIL - (1 = SIZE(op':= PNAME op)) or (char("*") ^= op'.0) => NIL - -- if there is a semicolon in the name then it is the name of - -- a compiled spad function - null (e := STRPOS('"_;",op',1,NIL)) => NIL - (char(" ") = (y := op'.1)) or (char("*") = y) => NIL - table := MAKETRTTABLE('"0123456789",NIL) - s := STRPOSL(table,op',1,true) - null(s) or s > e => NIL - SUBSTRING(op',s,e-s) - -application2String(op,argl, linkInfo) == - null argl => - (op' := isInternalFunctionName(op)) => op' - app2StringWrap(formWrapId op, linkInfo) - 1=#argl => - first argl is ["<",:.] => concat(op,first argl) - concat(app2StringWrap(formWrapId op, linkInfo)," ",first argl) ---op in '(UP SM) => --- newop:= (op = "UP" => "P";"M") --- concat(newop,concat(lbrkSch(),argl.0,rbrkSch(),argl.1)) ---op='RM =>concat("M",concat(lbrkSch(), --- argl.0,",",argl.1,rbrkSch(),argl.2)) ---op='MP =>concat("P",concat(argl.0,argl.1)) - op='SEGMENT => - null argl => '".." - (null rest argl) or (null first rest argl) => - concat(first argl, '"..") - concat(first argl, concat('"..", first rest argl)) - concat(app2StringWrap(formWrapId op, linkInfo) , - concat("_(",concat(tuple2String argl,"_)"))) - -app2StringConcat0(x,y) == - FORMAT(NIL, '"~a ~a", x, y) - -app2StringWrap(string, linkInfo) == - not linkInfo => string - $formatSigAsTeX = 1 => string - $formatSigAsTeX = 2 => - str2 := "app2StringConcat0"/form2Fence linkInfo - sep := '"`" - FORMAT(NIL, '"\lispLink{\verb!(|conPage| '~a)!}{~a}", - str2, string) - error "Bad value for $formatSigAsTeX" - -record2String x == - argPart := NIL - for [":",a,b] in x repeat argPart:= - concat(argPart,",",a,": ",form2StringLocal b) - null argPart => '"Record()" - concat("Record_(",rest argPart,"_)") - -plural(n,string) == - suffix:= - n = 1 => '"" - '"s" - [:bright n,string,suffix] - -formatIf pred == - not pred => nil - pred in '(T (QUOTE T)) => nil - concat('%b,'"if",'%d,pred2English pred) - -formatPredParts s == - s is ['QUOTE,s1] => formatPredParts s1 - s is ['LIST,:s1] => [formatPredParts s2 for s2 in s1] - s is ['devaluate,s1] => formatPredParts s1 - s is ['getDomainView,s1,.] => formatPredParts s1 - s is ['SUBST,a,b,c] => -- this is a signature - s1 := formatPredParts SUBST(formatPredParts a,b,c) - s1 isnt [fun,sig] => s1 - ['SIGNATURE,fun,[formatPredParts(r) for r in sig]] - s - -pred2English x == - x is ['IF,cond,thenClause,elseClause] => - c := concat('"if ",pred2English cond) - t := concat('" then ",pred2English thenClause) - e := concat('" else ",pred2English elseClause) - concat(c,t,e) - x is ['AND,:l] => - tail:="append"/[concat(bright '"and",pred2English x) for x in rest l] - concat(pred2English first l,tail) - x is ['OR,:l] => - tail:= "append"/[concat(bright '"or",pred2English x) for x in rest l] - concat(pred2English first l,tail) - x is ['NOT,l] => - concat('"not ",pred2English l) - x is [op,a,b] and op in '(has ofCategory) => - concat(pred2English a,'%b,'"has",'%d,form2String abbreviate b) - x is [op,a,b] and op in '(HasSignature HasAttribute HasCategory) => - concat(prefix2String0 formatPredParts a,'%b,'"has",'%d, - prefix2String0 formatPredParts b) - x is [op,a,b] and op in '(ofType getDomainView) => - if b is ['QUOTE,b'] then b := b' - concat(pred2English a,'": ",form2String abbreviate b) - x is [op,a,b] and op in '(isDomain domainEqual) => - concat(pred2English a,'" = ",form2String abbreviate b) - x is [op,:.] and (translation := LASSOC(op,'( - (_< . " < ") (_<_= . " <= ") - (_> . " > ") (_>_= . " >= ") (_= . " = ") (_^_= . " _^_= ")))) => - concat(pred2English a,translation,pred2English b) - x is ['ATTRIBUTE,form] => - concat("attribute: ",form2String form) - form2String x - -object2String x == - STRINGP x => x - IDENTP x => PNAME x - NULL x => '"" - PAIRP x => STRCONC(object2String first x, object2String rest x) - WRITE_-TO_-STRING x - -object2Identifier x == - IDENTP x => x - STRINGP x => INTERN x - INTERN WRITE_-TO_-STRING x - -blankList x == "append"/[[BLANK,y] for y in x] ---------------------> NEW DEFINITION (see cformat.boot.pamphlet) -pkey keyStuff == - if not PAIRP keyStuff then keyStuff := [keyStuff] - allMsgs := ['" "] - while not null keyStuff repeat - dbN := NIL - argL := NIL - key := first keyStuff - keyStuff := IFCDR keyStuff - next := IFCAR keyStuff - while PAIRP next repeat - if CAR next = 'dbN then dbN := CADR next - else argL := next - keyStuff := IFCDR keyStuff - next := IFCAR keyStuff - oneMsg := returnStLFromKey(key,argL,dbN) - allMsgs := ['" ", :NCONC (oneMsg,allMsgs)] - allMsgs - -string2Float s == - -- takes a string, calls the parser on it and returns a float object - p := ncParseFromString s - p isnt [["$elt", FloatDomain, "float"], x, y, z] => - systemError '"string2Float: did not get a float expression" - flt := getFunctionFromDomain("float", FloatDomain, - [$Integer, $Integer, $PositiveInteger]) - SPADCALL(x, y, z, flt) - - - -form2Fence form == - -- body of dbMkEvalable - [op, :.] := form - kind := GETDATABASE(op,'CONSTRUCTORKIND) - kind = 'category => form2Fence1 form - form2Fence1 mkEvalable form - -form2Fence1 x == - x is [op,:argl] => - op = 'QUOTE => ['"(QUOTE ",:form2FenceQuote first argl,'")"] - ['"(", FORMAT(NIL, '"|~a|", op),:"append"/[form2Fence1 y for y in argl],'")"] - IDENTP x => FORMAT(NIL, '"|~a|", x) --- [x] - ['" ", x] - -form2FenceQuote x == - NUMBERP x => [STRINGIMAGE x] - SYMBOLP x => [FORMAT(NIL, '"|~a|", x)] - atom x => '"??" - ['"(",:form2FenceQuote first x,:form2FenceQuoteTail rest x] - -form2FenceQuoteTail x == - null x => ['")"] - atom x => ['" . ",:form2FenceQuote x,'")"] - ['" ",:form2FenceQuote first x,:form2FenceQuoteTail rest x] - -form2StringList u == - atom (r := form2String u) => [r] - r -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/g-boot.boot b/src/interp/g-boot.boot new file mode 100644 index 00000000..793a7f06 --- /dev/null +++ b/src/interp/g-boot.boot @@ -0,0 +1,463 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- 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. + + +import '"def" +import '"g-util" +)package "BOOT" + +-- @(#)g-boot.boot 2.2 89/11/02 14:44:09 + +--% BOOT to LISP Translation + +-- these supplement those in DEF and MACRO LISP + +--% Utilities + + +$LET := 'SPADLET -- LET is a standard macro in Common Lisp + +nakedEXIT? c == + ATOM c => NIL + [a,:d] := c + IDENTP a => + a = 'EXIT => true + a = 'QUOTE => NIL + MEMQ(a,'(SEQ PROG LAMBDA MLAMBDA LAM)) => NIL + nakedEXIT?(d) + nakedEXIT?(a) or nakedEXIT?(d) + +mergeableCOND x == + ATOM(x) or x isnt ['COND,:cls] => NIL + -- to be mergeable, every result must be an EXIT and the last + -- predicate must be a pair + ok := true + while (cls and ok) repeat + [[p,:r],:cls] := cls + PAIRP QCDR r => ok := NIL + CAR(r) isnt ['EXIT,.] => ok := NIL + NULL(cls) and ATOM(p) => ok := NIL + NULL(cls) and (p = ''T) => ok := NIL + ok + +mergeCONDsWithEXITs l == + -- combines things like + -- (COND (foo (EXIT a))) + -- (COND (bar (EXIT b))) + -- into one COND + NULL l => NIL + ATOM l => l + NULL PAIRP QCDR l => l + a := QCAR l + if a is ['COND,:.] then a := flattenCOND a + am := mergeableCOND a + CDR(l) is [b,:k] and am and mergeableCOND(b) => + b:= flattenCOND b + c := ['COND,:QCDR a,:QCDR b] + mergeCONDsWithEXITs [flattenCOND c,:k] + CDR(l) is [b] and am => + [removeEXITFromCOND flattenCOND ['COND,:QCDR a,[''T,b]]] + [a,:mergeCONDsWithEXITs CDR l] + +removeEXITFromCOND? c == + -- c is '(COND ...) + -- only can do it if every clause simply EXITs + ok := true + c := CDR c + while ok and c repeat + [[p,:r],:c] := c + nakedEXIT? p => ok := NIL + [:f,r1] := r + nakedEXIT? f => ok := NIL + r1 isnt ['EXIT,r2] => ok := NIL + nakedEXIT? r2 => ok := NIL + ok + +removeEXITFromCOND c == + -- c is '(COND ...) + z := NIL + for cl in CDR c repeat + ATOM cl => z := CONS(cl,z) + cond := QCAR cl + length1? cl => + PAIRP(cond) and EQCAR(cond,'EXIT) => + z := CONS(QCDR cond,z) + z := CONS(cl,z) + cl' := REVERSE cl + lastSE := QCAR cl' + ATOM lastSE => z := CONS(cl,z) + EQCAR(lastSE,'EXIT) => + z := CONS(REVERSE CONS(CADR lastSE,CDR cl'),z) + z := CONS(cl,z) + CONS('COND,NREVERSE z) + +flattenCOND body == + -- transforms nested COND clauses to flat ones, if possible + body isnt ['COND,:.] => body + ['COND,:extractCONDClauses body] + +extractCONDClauses clauses == + -- extracts nested COND clauses into a flat structure + clauses is ['COND, [pred1,:act1],:restClauses] => + if act1 is [['PROGN,:acts]] then act1 := acts + restClauses is [[''T,restCond]] => + [[pred1,:act1],:extractCONDClauses restCond] + [[pred1,:act1],:restClauses] + [[''T,clauses]] + +--% COND and IF + +bootIF c == + -- handles IF expressions by turning them into CONDs + c is [.,p,t] => bootCOND ['COND,[p,t]] + [.,p,t,e] := c + bootCOND ['COND,[p,t],[''T,e]] + +bootCOND c == + -- handles COND expressions: c is ['COND,:.] + cls := CDR c + NULL cls => NIL + cls is [[''T,r],:.] => r + [:icls,fcls] := cls + ncls := NIL + for cl in icls repeat + [p,:r] := cl + ncls := + r is [['PROGN,:r1]] => CONS([p,:r1],ncls) + CONS(cl,ncls) + fcls := bootPushEXITintoCONDclause fcls + ncls := + fcls is [''T,['COND,:mcls]] => + APPEND(REVERSE mcls,ncls) + fcls is [''T,['PROGN,:mcls]] => + CONS([''T,:mcls],ncls) + CONS(fcls,ncls) + ['COND,:REVERSE ncls] + +bootPushEXITintoCONDclause e == + e isnt [''T,['EXIT,['COND,:cls]]] => e + ncls := NIL + for cl in cls repeat + [p,:r] := cl + ncls := + r is [['EXIT,:.]] => CONS(cl,ncls) + r is [r1] => CONS([p,['EXIT,r1]],ncls) + CONS([p,['EXIT,bootTran ['PROGN,:r]]],ncls) + [''T,['COND,:NREVERSE ncls]] + +--% SEQ and PROGN + +-- following is a more sophisticated def than that in MACRO LISP +-- it is used for boot code + +tryToRemoveSEQ e == + -- returns e if unsuccessful + e isnt ['SEQ,cl,:cls] => NIL + nakedEXIT? cl => + cl is ['COND,[p,['EXIT,r]],:ccls] => + nakedEXIT? p or nakedEXIT? r => e + null ccls => + bootCOND ['COND,[p,r],[''T,bootSEQ ['SEQ,:cls]]] + bootCOND ['COND,[p,r],[''T,bootSEQ ['SEQ,['COND,:ccls],:cls]]] + e + bootPROGN ['PROGN,cl,bootSEQ ['SEQ,:cls]] + +bootAbsorbSEQsAndPROGNs e == + -- assume e is a list from a SEQ or a PROGN + ATOM e => e + [:cls,lcl] := e + g := [:flatten(f) for f in cls] where + flatten x == + NULL x => NIL + IDENTP x => + MEMQ(x,$labelsForGO) => [x] + NIL + ATOM x => NIL + x is ['PROGN,:pcls,lpcl] => + ATOM lpcl => pcls + CDR x + -- next usually comes about from if foo then bar := zap + x is ['COND,y,[''T,'NIL]] => [['COND,y]] + [x] + while lcl is ['EXIT,f] repeat + lcl := f + lcl is ['PROGN,:pcls] => APPEND(g,pcls) + lcl is ['COND,[''T,:pcls]] => APPEND(g,pcls) + lcl is ['COND,[pred,['EXIT,h]]] => + APPEND(g,[['COND,[pred,h]]]) + APPEND(g,[lcl]) + +bootSEQ e == + e := ['SEQ,:mergeCONDsWithEXITs bootAbsorbSEQsAndPROGNs CDR e] + if e is [.,:cls,lcl] and IDENTP lcl and not MEMQ(lcl,$labelsForGO) then + e := ['SEQ,:cls,['EXIT,lcl]] + cls := QCDR e + cls is [['SEQ,:.]] => tryToRemoveSEQ QCAR cls + cls is [['EXIT,body]] => + nakedEXIT? body => bootTran ['SEQ,body] + body + not (nakedEXIT?(cls) or "or"/[MEMQ(g,$labelsForGO) for g in cls]) => + bootTran ['PROGN,:cls] + e is ['SEQ,['COND,[pred,['EXIT,r1]]],:r2] => + nakedEXIT?(pred) or nakedEXIT?(r1) or nakedEXIT?(r2) => + tryToRemoveSEQ e + bootTran ['COND,[pred,r1],[''T,:r2]] + tryToRemoveSEQ e + +bootPROGN e == + e := ['PROGN,:bootAbsorbSEQsAndPROGNs CDR e] + [.,:cls] := e + NULL cls => NIL + cls is [body] => body + e + +--% LET + +defLetForm(lhs,rhs) == +--if functionp lhs then +-- sayMSG ['"Danger: Reassigning value to LISP function:",:bright lhs] + [$LET,lhs,rhs] + +defLET1(lhs,rhs) == + IDENTP lhs => defLetForm(lhs,rhs) + lhs is ['FLUID,id] => defLetForm(lhs,rhs) + IDENTP rhs and not CONTAINED(rhs,lhs) => + rhs' := defLET2(lhs,rhs) + EQCAR(rhs',$LET) => MKPROGN [rhs',rhs] + EQCAR(rhs','PROGN) => APPEND(rhs',[rhs]) + if IDENTP CAR rhs' then rhs' := CONS(rhs',NIL) + MKPROGN [:rhs',rhs] + PAIRP(rhs) and EQCAR(rhs, $LET) and IDENTP(name := CADR rhs) => + -- handle things like [a] := x := foo + l1 := defLET1(name,CADDR rhs) + l2 := defLET1(lhs,name) + EQCAR(l2,'PROGN) => MKPROGN [l1,:CDR l2] + if IDENTP CAR l2 then l2 := cons(l2,nil) + MKPROGN [l1,:l2,name] + g := INTERN STRCONC('"LETTMP#",STRINGIMAGE $letGenVarCounter) + $letGenVarCounter := $letGenVarCounter + 1 + rhs' := [$LET,g,rhs] + let' := defLET1(lhs,g) + EQCAR(let','PROGN) => MKPROGN [rhs',:CDR let'] + if IDENTP CAR let' then let' := CONS(let',NIL) + MKPROGN [rhs',:let',g] + +defLET2(lhs,rhs) == + IDENTP lhs => defLetForm(lhs,rhs) + NULL lhs => NIL + lhs is ['FLUID,id] => defLetForm(lhs,rhs) + lhs is [=$LET,a,b] => + a := defLET2(a,rhs) + null (b := defLET2(b,rhs)) => a + ATOM b => [a,b] + PAIRP QCAR b => CONS(a,b) + [a,b] + lhs is ['CONS,var1,var2] => + var1 = "." or (PAIRP(var1) and EQCAR(var1,'QUOTE)) => + defLET2(var2,addCARorCDR('CDR,rhs)) + l1 := defLET2(var1,addCARorCDR('CAR,rhs)) + MEMQ(var2,'(NIL _.)) => l1 + if PAIRP l1 and ATOM CAR l1 then l1 := cons(l1,nil) + IDENTP var2 => + [:l1,defLetForm(var2,addCARorCDR('CDR,rhs))] + l2 := defLET2(var2,addCARorCDR('CDR,rhs)) + if PAIRP l2 and ATOM CAR l2 then l2 := cons(l2,nil) + APPEND(l1,l2) + lhs is ['APPEND,var1,var2] => + patrev := defISReverse(var2,var1) + rev := ['REVERSE,rhs] + g := INTERN STRCONC('"LETTMP#",STRINGIMAGE $letGenVarCounter) + $letGenVarCounter := $letGenVarCounter + 1 + l2 := defLET2(patrev,g) + if PAIRP l2 and ATOM CAR l2 then l2 := cons(l2,nil) + var1 = "." => [[$LET,g,rev],:l2] + last l2 is [=$LET, =var1, val1] => + [[$LET,g,rev],:REVERSE CDR REVERSE l2, + defLetForm(var1,['NREVERSE,val1])] + [[$LET,g,rev],:l2,defLetForm(var1,['NREVERSE,var1])] + lhs is ['EQUAL,var1] => + ['COND,[['EQUAL,var1,rhs],var1]] + -- let the IS code take over from here + isPred := + $inDefIS => defIS1(rhs,lhs) + defIS(rhs,lhs) + ['COND,[isPred,rhs]] + +defLET(lhs,rhs) == + $letGenVarCounter : local := 1 + $inDefLET : local := true + defLET1(lhs,rhs) + +addCARorCDR(acc,expr) == + NULL PAIRP expr => [acc,expr] + acc = 'CAR and EQCAR(expr,'REVERSE) => + cons('last,QCDR expr) + funs := '(CAR CDR CAAR CDAR CADR CDDR CAAAR CADAR CAADR CADDR + CDAAR CDDAR CDADR CDDDR) + p := position(QCAR expr,funs) + p = -1 => [acc,expr] + funsA := '(CAAR CADR CAAAR CADAR CAADR CADDR CAAAAR CAADAR CAAADR + CAADDR CADAAR CADDAR CADADR CADDDR) + funsR := '(CDAR CDDR CDAAR CDDAR CDADR CDDDR CDAAAR CDADAR CDAADR + CDADDR CDDAAR CDDDAR CDDADR CDDDDR) + if acc = 'CAR then CONS(funsA.p,QCDR expr) + else CONS(funsR.p,QCDR expr) + + +--% IS + +defISReverse(x,a) == + -- reverses forms coming from APPENDs in patterns + -- pretty much just a translation of DEF-IS-REV + x is ['CONS,:.] => + NULL CADDR x => ['CONS,CADR x, a] + y := defISReverse(CADDR x, NIL) + RPLAC(CADDR y,['CONS,CADR x,a]) + y + ERRHUH() + +defIS1(lhs,rhs) == + NULL rhs => + ['NULL,lhs] + STRINGP rhs => + ['EQ,lhs,['QUOTE,INTERN rhs]] + NUMBERP rhs => + ['EQUAL,lhs,rhs] + ATOM rhs => + ['PROGN,defLetForm(rhs,lhs),''T] + rhs is ['QUOTE,a] => + IDENTP a => ['EQ,lhs,rhs] + ['EQUAL,lhs,rhs] + rhs is [=$LET,c,d] => + l := + $inDefLET => defLET1(c,lhs) + defLET(c,lhs) + ['AND,defIS1(lhs,d),MKPROGN [l,''T]] + rhs is ['EQUAL,a] => + ['EQUAL,lhs,a] + PAIRP lhs => + g := INTERN STRCONC('"ISTMP#",STRINGIMAGE $isGenVarCounter) + $isGenVarCounter := $isGenVarCounter + 1 + MKPROGN [[$LET,g,lhs],defIS1(g,rhs)] + rhs is ['CONS,a,b] => + a = "." => + NULL b => + ['AND,['PAIRP,lhs], + ['EQ,['QCDR,lhs],'NIL]] + ['AND,['PAIRP,lhs], + defIS1(['QCDR,lhs],b)] + NULL b => + ['AND,['PAIRP,lhs], + ['EQ,['QCDR,lhs],'NIL],_ + defIS1(['QCAR,lhs],a)] + b = "." => + ['AND,['PAIRP,lhs],defIS1(['QCAR,lhs],a)] + a1 := defIS1(['QCAR,lhs],a) + b1 := defIS1(['QCDR,lhs],b) + a1 is ['PROGN,c,''T] and b1 is ['PROGN,:cls] => + ['AND,['PAIRP,lhs],MKPROGN [c,:cls]] + ['AND,['PAIRP,lhs],a1,b1] + rhs is ['APPEND,a,b] => + patrev := defISReverse(b,a) + g := INTERN STRCONC('"ISTMP#",STRINGIMAGE $isGenVarCounter) + $isGenVarCounter := $isGenVarCounter + 1 + rev := ['AND,['PAIRP,lhs],['PROGN,[$LET,g,['REVERSE,lhs]],''T]] + l2 := defIS1(g,patrev) + if PAIRP l2 and ATOM CAR l2 then l2 := cons(l2,nil) + a = "." => ['AND,rev,:l2] + ['AND,rev,:l2,['PROGN,defLetForm(a,['NREVERSE,a]),''T]] + SAY '"WARNING (defIS1): possibly bad IS code being generated" + DEF_-IS [lhs,rhs] + +defIS(lhs,rhs) == + $isGenVarCounter : local := 1 + $inDefIS : local := true + defIS1(DEFTRAN lhs,rhs) + +--% OR and AND + +bootOR e == + -- flatten any contained ORs. + cls := CDR e + NULL cls => NIL + NULL CDR cls => CAR cls + ncls := [:flatten(c) for c in cls] where + flatten x == + x is ['OR,:.] => QCDR x + [x] + ['OR,:ncls] + +bootAND e == + -- flatten any contained ANDs. + cls := CDR e + NULL cls => 'T + NULL CDR cls => CAR cls + ncls := [:flatten(c) for c in cls] where + flatten x == + x is ['AND,:.] => QCDR x + [x] + ['AND,:ncls] + +--% Main Transformation Functions + +bootLabelsForGO e == + ATOM e => NIL + [head,:tail] := e + IDENTP head => + head = 'GO => $labelsForGO := CONS(CAR tail,$labelsForGO) + head = 'QUOTE => NIL + bootLabelsForGO tail + bootLabelsForGO head + bootLabelsForGO tail + +bootTran e == + ATOM e => e + [head,:tail] := e + head = 'QUOTE => e + tail := [bootTran t for t in tail] + e := [head,:tail] + IDENTP head => + head = 'IF => bootIF e + head = 'COND => bootCOND e + head = 'PROGN => bootPROGN e + head = 'SEQ => bootSEQ e + head = 'OR => bootOR e + head = 'AND => bootAND e + e + [bootTran head,:QCDR e] + +bootTransform e == +--NULL $BOOT => e + $labelsForGO : local := NIL + bootLabelsForGO e + bootTran e diff --git a/src/interp/g-boot.boot.pamphlet b/src/interp/g-boot.boot.pamphlet deleted file mode 100644 index a754a951..00000000 --- a/src/interp/g-boot.boot.pamphlet +++ /dev/null @@ -1,487 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/g-boot.boot} Pamphlet} -\author{The Axiom Team} - -\begin{document} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\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. - -@ -<<*>>= -<> - -import '"def" -import '"g-util" -)package "BOOT" - --- @(#)g-boot.boot 2.2 89/11/02 14:44:09 - ---% BOOT to LISP Translation - --- these supplement those in DEF and MACRO LISP - ---% Utilities - - -$LET := 'SPADLET -- LET is a standard macro in Common Lisp - -nakedEXIT? c == - ATOM c => NIL - [a,:d] := c - IDENTP a => - a = 'EXIT => true - a = 'QUOTE => NIL - MEMQ(a,'(SEQ PROG LAMBDA MLAMBDA LAM)) => NIL - nakedEXIT?(d) - nakedEXIT?(a) or nakedEXIT?(d) - -mergeableCOND x == - ATOM(x) or x isnt ['COND,:cls] => NIL - -- to be mergeable, every result must be an EXIT and the last - -- predicate must be a pair - ok := true - while (cls and ok) repeat - [[p,:r],:cls] := cls - PAIRP QCDR r => ok := NIL - CAR(r) isnt ['EXIT,.] => ok := NIL - NULL(cls) and ATOM(p) => ok := NIL - NULL(cls) and (p = ''T) => ok := NIL - ok - -mergeCONDsWithEXITs l == - -- combines things like - -- (COND (foo (EXIT a))) - -- (COND (bar (EXIT b))) - -- into one COND - NULL l => NIL - ATOM l => l - NULL PAIRP QCDR l => l - a := QCAR l - if a is ['COND,:.] then a := flattenCOND a - am := mergeableCOND a - CDR(l) is [b,:k] and am and mergeableCOND(b) => - b:= flattenCOND b - c := ['COND,:QCDR a,:QCDR b] - mergeCONDsWithEXITs [flattenCOND c,:k] - CDR(l) is [b] and am => - [removeEXITFromCOND flattenCOND ['COND,:QCDR a,[''T,b]]] - [a,:mergeCONDsWithEXITs CDR l] - -removeEXITFromCOND? c == - -- c is '(COND ...) - -- only can do it if every clause simply EXITs - ok := true - c := CDR c - while ok and c repeat - [[p,:r],:c] := c - nakedEXIT? p => ok := NIL - [:f,r1] := r - nakedEXIT? f => ok := NIL - r1 isnt ['EXIT,r2] => ok := NIL - nakedEXIT? r2 => ok := NIL - ok - -removeEXITFromCOND c == - -- c is '(COND ...) - z := NIL - for cl in CDR c repeat - ATOM cl => z := CONS(cl,z) - cond := QCAR cl - length1? cl => - PAIRP(cond) and EQCAR(cond,'EXIT) => - z := CONS(QCDR cond,z) - z := CONS(cl,z) - cl' := REVERSE cl - lastSE := QCAR cl' - ATOM lastSE => z := CONS(cl,z) - EQCAR(lastSE,'EXIT) => - z := CONS(REVERSE CONS(CADR lastSE,CDR cl'),z) - z := CONS(cl,z) - CONS('COND,NREVERSE z) - -flattenCOND body == - -- transforms nested COND clauses to flat ones, if possible - body isnt ['COND,:.] => body - ['COND,:extractCONDClauses body] - -extractCONDClauses clauses == - -- extracts nested COND clauses into a flat structure - clauses is ['COND, [pred1,:act1],:restClauses] => - if act1 is [['PROGN,:acts]] then act1 := acts - restClauses is [[''T,restCond]] => - [[pred1,:act1],:extractCONDClauses restCond] - [[pred1,:act1],:restClauses] - [[''T,clauses]] - ---% COND and IF - -bootIF c == - -- handles IF expressions by turning them into CONDs - c is [.,p,t] => bootCOND ['COND,[p,t]] - [.,p,t,e] := c - bootCOND ['COND,[p,t],[''T,e]] - -bootCOND c == - -- handles COND expressions: c is ['COND,:.] - cls := CDR c - NULL cls => NIL - cls is [[''T,r],:.] => r - [:icls,fcls] := cls - ncls := NIL - for cl in icls repeat - [p,:r] := cl - ncls := - r is [['PROGN,:r1]] => CONS([p,:r1],ncls) - CONS(cl,ncls) - fcls := bootPushEXITintoCONDclause fcls - ncls := - fcls is [''T,['COND,:mcls]] => - APPEND(REVERSE mcls,ncls) - fcls is [''T,['PROGN,:mcls]] => - CONS([''T,:mcls],ncls) - CONS(fcls,ncls) - ['COND,:REVERSE ncls] - -bootPushEXITintoCONDclause e == - e isnt [''T,['EXIT,['COND,:cls]]] => e - ncls := NIL - for cl in cls repeat - [p,:r] := cl - ncls := - r is [['EXIT,:.]] => CONS(cl,ncls) - r is [r1] => CONS([p,['EXIT,r1]],ncls) - CONS([p,['EXIT,bootTran ['PROGN,:r]]],ncls) - [''T,['COND,:NREVERSE ncls]] - ---% SEQ and PROGN - --- following is a more sophisticated def than that in MACRO LISP --- it is used for boot code - -tryToRemoveSEQ e == - -- returns e if unsuccessful - e isnt ['SEQ,cl,:cls] => NIL - nakedEXIT? cl => - cl is ['COND,[p,['EXIT,r]],:ccls] => - nakedEXIT? p or nakedEXIT? r => e - null ccls => - bootCOND ['COND,[p,r],[''T,bootSEQ ['SEQ,:cls]]] - bootCOND ['COND,[p,r],[''T,bootSEQ ['SEQ,['COND,:ccls],:cls]]] - e - bootPROGN ['PROGN,cl,bootSEQ ['SEQ,:cls]] - -bootAbsorbSEQsAndPROGNs e == - -- assume e is a list from a SEQ or a PROGN - ATOM e => e - [:cls,lcl] := e - g := [:flatten(f) for f in cls] where - flatten x == - NULL x => NIL - IDENTP x => - MEMQ(x,$labelsForGO) => [x] - NIL - ATOM x => NIL - x is ['PROGN,:pcls,lpcl] => - ATOM lpcl => pcls - CDR x - -- next usually comes about from if foo then bar := zap - x is ['COND,y,[''T,'NIL]] => [['COND,y]] - [x] - while lcl is ['EXIT,f] repeat - lcl := f - lcl is ['PROGN,:pcls] => APPEND(g,pcls) - lcl is ['COND,[''T,:pcls]] => APPEND(g,pcls) - lcl is ['COND,[pred,['EXIT,h]]] => - APPEND(g,[['COND,[pred,h]]]) - APPEND(g,[lcl]) - -bootSEQ e == - e := ['SEQ,:mergeCONDsWithEXITs bootAbsorbSEQsAndPROGNs CDR e] - if e is [.,:cls,lcl] and IDENTP lcl and not MEMQ(lcl,$labelsForGO) then - e := ['SEQ,:cls,['EXIT,lcl]] - cls := QCDR e - cls is [['SEQ,:.]] => tryToRemoveSEQ QCAR cls - cls is [['EXIT,body]] => - nakedEXIT? body => bootTran ['SEQ,body] - body - not (nakedEXIT?(cls) or "or"/[MEMQ(g,$labelsForGO) for g in cls]) => - bootTran ['PROGN,:cls] - e is ['SEQ,['COND,[pred,['EXIT,r1]]],:r2] => - nakedEXIT?(pred) or nakedEXIT?(r1) or nakedEXIT?(r2) => - tryToRemoveSEQ e - bootTran ['COND,[pred,r1],[''T,:r2]] - tryToRemoveSEQ e - -bootPROGN e == - e := ['PROGN,:bootAbsorbSEQsAndPROGNs CDR e] - [.,:cls] := e - NULL cls => NIL - cls is [body] => body - e - ---% LET - -defLetForm(lhs,rhs) == ---if functionp lhs then --- sayMSG ['"Danger: Reassigning value to LISP function:",:bright lhs] - [$LET,lhs,rhs] - -defLET1(lhs,rhs) == - IDENTP lhs => defLetForm(lhs,rhs) - lhs is ['FLUID,id] => defLetForm(lhs,rhs) - IDENTP rhs and not CONTAINED(rhs,lhs) => - rhs' := defLET2(lhs,rhs) - EQCAR(rhs',$LET) => MKPROGN [rhs',rhs] - EQCAR(rhs','PROGN) => APPEND(rhs',[rhs]) - if IDENTP CAR rhs' then rhs' := CONS(rhs',NIL) - MKPROGN [:rhs',rhs] - PAIRP(rhs) and EQCAR(rhs, $LET) and IDENTP(name := CADR rhs) => - -- handle things like [a] := x := foo - l1 := defLET1(name,CADDR rhs) - l2 := defLET1(lhs,name) - EQCAR(l2,'PROGN) => MKPROGN [l1,:CDR l2] - if IDENTP CAR l2 then l2 := cons(l2,nil) - MKPROGN [l1,:l2,name] - g := INTERN STRCONC('"LETTMP#",STRINGIMAGE $letGenVarCounter) - $letGenVarCounter := $letGenVarCounter + 1 - rhs' := [$LET,g,rhs] - let' := defLET1(lhs,g) - EQCAR(let','PROGN) => MKPROGN [rhs',:CDR let'] - if IDENTP CAR let' then let' := CONS(let',NIL) - MKPROGN [rhs',:let',g] - -defLET2(lhs,rhs) == - IDENTP lhs => defLetForm(lhs,rhs) - NULL lhs => NIL - lhs is ['FLUID,id] => defLetForm(lhs,rhs) - lhs is [=$LET,a,b] => - a := defLET2(a,rhs) - null (b := defLET2(b,rhs)) => a - ATOM b => [a,b] - PAIRP QCAR b => CONS(a,b) - [a,b] - lhs is ['CONS,var1,var2] => - var1 = "." or (PAIRP(var1) and EQCAR(var1,'QUOTE)) => - defLET2(var2,addCARorCDR('CDR,rhs)) - l1 := defLET2(var1,addCARorCDR('CAR,rhs)) - MEMQ(var2,'(NIL _.)) => l1 - if PAIRP l1 and ATOM CAR l1 then l1 := cons(l1,nil) - IDENTP var2 => - [:l1,defLetForm(var2,addCARorCDR('CDR,rhs))] - l2 := defLET2(var2,addCARorCDR('CDR,rhs)) - if PAIRP l2 and ATOM CAR l2 then l2 := cons(l2,nil) - APPEND(l1,l2) - lhs is ['APPEND,var1,var2] => - patrev := defISReverse(var2,var1) - rev := ['REVERSE,rhs] - g := INTERN STRCONC('"LETTMP#",STRINGIMAGE $letGenVarCounter) - $letGenVarCounter := $letGenVarCounter + 1 - l2 := defLET2(patrev,g) - if PAIRP l2 and ATOM CAR l2 then l2 := cons(l2,nil) - var1 = "." => [[$LET,g,rev],:l2] - last l2 is [=$LET, =var1, val1] => - [[$LET,g,rev],:REVERSE CDR REVERSE l2, - defLetForm(var1,['NREVERSE,val1])] - [[$LET,g,rev],:l2,defLetForm(var1,['NREVERSE,var1])] - lhs is ['EQUAL,var1] => - ['COND,[['EQUAL,var1,rhs],var1]] - -- let the IS code take over from here - isPred := - $inDefIS => defIS1(rhs,lhs) - defIS(rhs,lhs) - ['COND,[isPred,rhs]] - -defLET(lhs,rhs) == - $letGenVarCounter : local := 1 - $inDefLET : local := true - defLET1(lhs,rhs) - -addCARorCDR(acc,expr) == - NULL PAIRP expr => [acc,expr] - acc = 'CAR and EQCAR(expr,'REVERSE) => - cons('last,QCDR expr) - funs := '(CAR CDR CAAR CDAR CADR CDDR CAAAR CADAR CAADR CADDR - CDAAR CDDAR CDADR CDDDR) - p := position(QCAR expr,funs) - p = -1 => [acc,expr] - funsA := '(CAAR CADR CAAAR CADAR CAADR CADDR CAAAAR CAADAR CAAADR - CAADDR CADAAR CADDAR CADADR CADDDR) - funsR := '(CDAR CDDR CDAAR CDDAR CDADR CDDDR CDAAAR CDADAR CDAADR - CDADDR CDDAAR CDDDAR CDDADR CDDDDR) - if acc = 'CAR then CONS(funsA.p,QCDR expr) - else CONS(funsR.p,QCDR expr) - - ---% IS - -defISReverse(x,a) == - -- reverses forms coming from APPENDs in patterns - -- pretty much just a translation of DEF-IS-REV - x is ['CONS,:.] => - NULL CADDR x => ['CONS,CADR x, a] - y := defISReverse(CADDR x, NIL) - RPLAC(CADDR y,['CONS,CADR x,a]) - y - ERRHUH() - -defIS1(lhs,rhs) == - NULL rhs => - ['NULL,lhs] - STRINGP rhs => - ['EQ,lhs,['QUOTE,INTERN rhs]] - NUMBERP rhs => - ['EQUAL,lhs,rhs] - ATOM rhs => - ['PROGN,defLetForm(rhs,lhs),''T] - rhs is ['QUOTE,a] => - IDENTP a => ['EQ,lhs,rhs] - ['EQUAL,lhs,rhs] - rhs is [=$LET,c,d] => - l := - $inDefLET => defLET1(c,lhs) - defLET(c,lhs) - ['AND,defIS1(lhs,d),MKPROGN [l,''T]] - rhs is ['EQUAL,a] => - ['EQUAL,lhs,a] - PAIRP lhs => - g := INTERN STRCONC('"ISTMP#",STRINGIMAGE $isGenVarCounter) - $isGenVarCounter := $isGenVarCounter + 1 - MKPROGN [[$LET,g,lhs],defIS1(g,rhs)] - rhs is ['CONS,a,b] => - a = "." => - NULL b => - ['AND,['PAIRP,lhs], - ['EQ,['QCDR,lhs],'NIL]] - ['AND,['PAIRP,lhs], - defIS1(['QCDR,lhs],b)] - NULL b => - ['AND,['PAIRP,lhs], - ['EQ,['QCDR,lhs],'NIL],_ - defIS1(['QCAR,lhs],a)] - b = "." => - ['AND,['PAIRP,lhs],defIS1(['QCAR,lhs],a)] - a1 := defIS1(['QCAR,lhs],a) - b1 := defIS1(['QCDR,lhs],b) - a1 is ['PROGN,c,''T] and b1 is ['PROGN,:cls] => - ['AND,['PAIRP,lhs],MKPROGN [c,:cls]] - ['AND,['PAIRP,lhs],a1,b1] - rhs is ['APPEND,a,b] => - patrev := defISReverse(b,a) - g := INTERN STRCONC('"ISTMP#",STRINGIMAGE $isGenVarCounter) - $isGenVarCounter := $isGenVarCounter + 1 - rev := ['AND,['PAIRP,lhs],['PROGN,[$LET,g,['REVERSE,lhs]],''T]] - l2 := defIS1(g,patrev) - if PAIRP l2 and ATOM CAR l2 then l2 := cons(l2,nil) - a = "." => ['AND,rev,:l2] - ['AND,rev,:l2,['PROGN,defLetForm(a,['NREVERSE,a]),''T]] - SAY '"WARNING (defIS1): possibly bad IS code being generated" - DEF_-IS [lhs,rhs] - -defIS(lhs,rhs) == - $isGenVarCounter : local := 1 - $inDefIS : local := true - defIS1(DEFTRAN lhs,rhs) - ---% OR and AND - -bootOR e == - -- flatten any contained ORs. - cls := CDR e - NULL cls => NIL - NULL CDR cls => CAR cls - ncls := [:flatten(c) for c in cls] where - flatten x == - x is ['OR,:.] => QCDR x - [x] - ['OR,:ncls] - -bootAND e == - -- flatten any contained ANDs. - cls := CDR e - NULL cls => 'T - NULL CDR cls => CAR cls - ncls := [:flatten(c) for c in cls] where - flatten x == - x is ['AND,:.] => QCDR x - [x] - ['AND,:ncls] - ---% Main Transformation Functions - -bootLabelsForGO e == - ATOM e => NIL - [head,:tail] := e - IDENTP head => - head = 'GO => $labelsForGO := CONS(CAR tail,$labelsForGO) - head = 'QUOTE => NIL - bootLabelsForGO tail - bootLabelsForGO head - bootLabelsForGO tail - -bootTran e == - ATOM e => e - [head,:tail] := e - head = 'QUOTE => e - tail := [bootTran t for t in tail] - e := [head,:tail] - IDENTP head => - head = 'IF => bootIF e - head = 'COND => bootCOND e - head = 'PROGN => bootPROGN e - head = 'SEQ => bootSEQ e - head = 'OR => bootOR e - head = 'AND => bootAND e - e - [bootTran head,:QCDR e] - -bootTransform e == ---NULL $BOOT => e - $labelsForGO : local := NIL - bootLabelsForGO e - bootTran e -@ - -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/g-cndata.boot b/src/interp/g-cndata.boot new file mode 100644 index 00000000..d6a4ce66 --- /dev/null +++ b/src/interp/g-cndata.boot @@ -0,0 +1,245 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- 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. + + +import '"sys-macros" +)package "BOOT" + +--% Manipulation of Constructor Datat + +--======================================================================= +-- Build Table of Lower Case Constructor Names +--======================================================================= +mkLowerCaseConTable() == +--Called at system build time by function BUILD-INTERPSYS (see util.lisp) +--Table is referenced by functions conPageFastPath and grepForAbbrev + $lowerCaseConTb := MAKE_-HASH_-TABLE() + for x in allConstructors() repeat augmentLowerCaseConTable x + $lowerCaseConTb + +augmentLowerCaseConTable x == + y:=GETDATABASE(x,'ABBREVIATION) + item:=[x,y,nil] + HPUT($lowerCaseConTb,x,item) + HPUT($lowerCaseConTb,DOWNCASE x,item) + HPUT($lowerCaseConTb,y,item) + +getCDTEntry(info,isName) == + not IDENTP info => NIL + (entry := HGET($lowerCaseConTb,info)) => + [name,abb,:.] := entry + isName and EQ(name,info) => entry + not isName and EQ(abb,info) => entry + NIL + entry + +putConstructorProperty(name,prop,val) == + null (entry := getCDTEntry(name,true)) => NIL + RPLACD(CDR entry,PUTALIST(CDDR entry,prop,val)) + true + +attribute? name == + MEMQ(name, _*ATTRIBUTES_*) + +abbreviation? abb == + -- if it is an abbreviation, return the corresponding name + GETDATABASE(abb,'CONSTRUCTOR) + +constructor? name == + -- if it is a constructor name, return the abbreviation + GETDATABASE(name,'ABBREVIATION) + +domainForm? d == + GETDATABASE(opOf d,'CONSTRUCTORKIND) = 'domain + +packageForm? d == + GETDATABASE(opOf d,'CONSTRUCTORKIND) = 'package + +categoryForm? c == + op := opOf c + MEMQ(op, $CategoryNames) => true + GETDATABASE(op,'CONSTRUCTORKIND) = 'category => true + nil + +getImmediateSuperDomain(d) == + IFCAR GETDATABASE(opOf d, 'SUPERDOMAIN) + +maximalSuperType d == + d' := GETDATABASE(opOf d, 'SUPERDOMAIN) => maximalSuperType first d' + d + +-- probably will switch over to 'libName soon +getLisplibName(c) == getConstructorAbbreviation(c) + +getConstructorAbbreviation op == + constructor?(op) or throwKeyedMsg("S2IL0015",[op]) + +getConstructorUnabbreviation op == + abbreviation?(op) or throwKeyedMsg("S2IL0019",[op]) + +mkUserConstructorAbbreviation(c,a,type) == + if not atom c then c:= CAR c -- Existing constructors will be wrapped + constructorAbbreviationErrorCheck(c,a,type,'abbreviationError) + clearClams() + clearConstructorCache(c) + installConstructor(c,type) + setAutoLoadProperty(c) + +abbQuery(x) == + abb := GETDATABASE(x,'ABBREVIATION) => + sayKeyedMsg("S2IZ0001",[abb,GETDATABASE(x,'CONSTRUCTORKIND),x]) + sayKeyedMsg("S2IZ0003",[x]) + +installConstructor(cname,type) == + (entry := getCDTEntry(cname,true)) => entry + item := [cname,GETDATABASE(cname,'ABBREVIATION),nil] + if BOUNDP '$lowerCaseConTb and $lowerCaseConTb then + HPUT($lowerCaseConTb,cname,item) + HPUT($lowerCaseConTb,DOWNCASE cname,item) + +constructorNameConflict(name,kind) == + userError + ["The name",:bright name,"conflicts with the name of an existing rule", + "%l","please choose another ",kind] + +constructorAbbreviationErrorCheck(c,a,typ,errmess) == + siz := SIZE (s := PNAME a) + if typ = 'category and siz > 7 + then throwKeyedErrorMsg('precompilation,"S2IL0021",NIL) + if siz > 8 then throwKeyedErrorMsg('precompilation,"S2IL0006",NIL) + if s ^= UPCASE s then throwKeyedMsg("S2IL0006",NIL) + abb := GETDATABASE(c,'ABBREVIATION) + name:= GETDATABASE(a,'CONSTRUCTOR) + type := GETDATABASE(c,'CONSTRUCTORKIND) + a=abb and c^=name => lisplibError(c,a,typ,abb,name,type,'duplicateAbb) + a=name and c^=name => lisplibError(c,a,typ,abb,name,type,'abbIsName) + c=name and typ^=type => lisplibError(c,a,typ,abb,name,type,'wrongType) + +abbreviationError(c,a,typ,abb,name,type,error) == + sayKeyedMsg("S2IL0009",[a,typ,c]) + error='duplicateAbb => + throwKeyedMsg("S2IL0010",[a,typ,name]) + error='abbIsName => + throwKeyedMsg("S2IL0011",[a,type]) + error='wrongType => + throwKeyedMsg("S2IL0012",[c,type]) + NIL + +abbreviate u == + u is ['Union,:arglist] => + ['Union,:[abbreviate a for a in arglist]] + u is [op,:arglist] => + abb := constructor?(op) => + [abb,:condAbbrev(arglist,getPartialConstructorModemapSig(op))] + u + constructor?(u) or u + +unabbrev u == unabbrev1(u,nil) + +unabbrevAndLoad u == unabbrev1(u,true) + +isNameOfType x == + $doNotAddEmptyModeIfTrue:local:= true + (val := get(x,'value,$InteractiveFrame)) and + (domain := objMode val) and + domain in '((Mode) (Domain) (SubDomain (Domain))) => true + y := opOf unabbrev x + constructor? y + +unabbrev1(u,modeIfTrue) == + atom u => + modeIfTrue => + d:= isDomainValuedVariable u => u + a := abbreviation? u => + GETDATABASE(a,'NILADIC) => [a] + largs := ['_$EmptyMode for arg in + getPartialConstructorModemapSig(a)] + unabbrev1([u,:largs],modeIfTrue) + u + a:= abbreviation?(u) or u + GETDATABASE(a,'NILADIC) => [a] + a + [op,:arglist] := u + op = 'Join => ['Join, :[unabbrev1(x, modeIfTrue) for x in arglist]] + d:= isDomainValuedVariable op => + throwKeyedMsg("S2IL0013",[op,d]) + (r := unabbrevSpecialForms(op,arglist,modeIfTrue)) => r + (cname := abbreviation? op) or (constructor?(op) and (cname := op)) => + (r := unabbrevSpecialForms(cname,arglist,modeIfTrue)) => r + -- ??? if modeIfTrue then loadIfNecessary cname + [cname,:condUnabbrev(op,arglist, + getPartialConstructorModemapSig(cname),modeIfTrue)] + u + +unabbrevSpecialForms(op,arglist,modeIfTrue) == + op = 'Mapping => [op,:[unabbrev1(a,modeIfTrue) for a in arglist]] + op = 'Union => + [op,:[unabbrevUnionComponent(a,modeIfTrue) for a in arglist]] + op = 'Record => + [op,:[unabbrevRecordComponent(a,modeIfTrue) for a in arglist]] + nil + +unabbrevRecordComponent(a,modeIfTrue) == + a is ["Declare",b,T] or a is [":",b,T] => + [":",b,unabbrev1(T,modeIfTrue)] + userError "wrong format for Record type" + +unabbrevUnionComponent(a,modeIfTrue) == + a is ["Declare",b,T] or a is [":",b,T] => + [":",b,unabbrev1(T,modeIfTrue)] + unabbrev1(a, modeIfTrue) + +condAbbrev(arglist,argtypes) == + res:= nil + for arg in arglist for type in argtypes repeat + if categoryForm?(type) then arg:= abbreviate arg + res:=[:res,arg] + res + +condUnabbrev(op,arglist,argtypes,modeIfTrue) == + #arglist ^= #argtypes => + throwKeyedMsg("S2IL0014",[op,plural(#argtypes,'"argument"), + bright(#arglist)]) + [newArg for arg in arglist for type in argtypes] where newArg() == + categoryForm?(type) => unabbrev1(arg,modeIfTrue) + arg + +--% Code Being Phased Out + +nAssocQ(x,l,n) == + repeat + if atom l then return nil + if EQ(x,(QCAR l).n) then return QCAR l + l:= QCDR l + + diff --git a/src/interp/g-cndata.boot.pamphlet b/src/interp/g-cndata.boot.pamphlet deleted file mode 100644 index 6c0efdac..00000000 --- a/src/interp/g-cndata.boot.pamphlet +++ /dev/null @@ -1,265 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp g-cndata.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\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. - -@ -<<*>>= -<> - -import '"sys-macros" -)package "BOOT" - ---% Manipulation of Constructor Datat - ---======================================================================= --- Build Table of Lower Case Constructor Names ---======================================================================= -mkLowerCaseConTable() == ---Called at system build time by function BUILD-INTERPSYS (see util.lisp) ---Table is referenced by functions conPageFastPath and grepForAbbrev - $lowerCaseConTb := MAKE_-HASH_-TABLE() - for x in allConstructors() repeat augmentLowerCaseConTable x - $lowerCaseConTb - -augmentLowerCaseConTable x == - y:=GETDATABASE(x,'ABBREVIATION) - item:=[x,y,nil] - HPUT($lowerCaseConTb,x,item) - HPUT($lowerCaseConTb,DOWNCASE x,item) - HPUT($lowerCaseConTb,y,item) - -getCDTEntry(info,isName) == - not IDENTP info => NIL - (entry := HGET($lowerCaseConTb,info)) => - [name,abb,:.] := entry - isName and EQ(name,info) => entry - not isName and EQ(abb,info) => entry - NIL - entry - -putConstructorProperty(name,prop,val) == - null (entry := getCDTEntry(name,true)) => NIL - RPLACD(CDR entry,PUTALIST(CDDR entry,prop,val)) - true - -attribute? name == - MEMQ(name, _*ATTRIBUTES_*) - -abbreviation? abb == - -- if it is an abbreviation, return the corresponding name - GETDATABASE(abb,'CONSTRUCTOR) - -constructor? name == - -- if it is a constructor name, return the abbreviation - GETDATABASE(name,'ABBREVIATION) - -domainForm? d == - GETDATABASE(opOf d,'CONSTRUCTORKIND) = 'domain - -packageForm? d == - GETDATABASE(opOf d,'CONSTRUCTORKIND) = 'package - -categoryForm? c == - op := opOf c - MEMQ(op, $CategoryNames) => true - GETDATABASE(op,'CONSTRUCTORKIND) = 'category => true - nil - -getImmediateSuperDomain(d) == - IFCAR GETDATABASE(opOf d, 'SUPERDOMAIN) - -maximalSuperType d == - d' := GETDATABASE(opOf d, 'SUPERDOMAIN) => maximalSuperType first d' - d - --- probably will switch over to 'libName soon -getLisplibName(c) == getConstructorAbbreviation(c) - -getConstructorAbbreviation op == - constructor?(op) or throwKeyedMsg("S2IL0015",[op]) - -getConstructorUnabbreviation op == - abbreviation?(op) or throwKeyedMsg("S2IL0019",[op]) - -mkUserConstructorAbbreviation(c,a,type) == - if not atom c then c:= CAR c -- Existing constructors will be wrapped - constructorAbbreviationErrorCheck(c,a,type,'abbreviationError) - clearClams() - clearConstructorCache(c) - installConstructor(c,type) - setAutoLoadProperty(c) - -abbQuery(x) == - abb := GETDATABASE(x,'ABBREVIATION) => - sayKeyedMsg("S2IZ0001",[abb,GETDATABASE(x,'CONSTRUCTORKIND),x]) - sayKeyedMsg("S2IZ0003",[x]) - -installConstructor(cname,type) == - (entry := getCDTEntry(cname,true)) => entry - item := [cname,GETDATABASE(cname,'ABBREVIATION),nil] - if BOUNDP '$lowerCaseConTb and $lowerCaseConTb then - HPUT($lowerCaseConTb,cname,item) - HPUT($lowerCaseConTb,DOWNCASE cname,item) - -constructorNameConflict(name,kind) == - userError - ["The name",:bright name,"conflicts with the name of an existing rule", - "%l","please choose another ",kind] - -constructorAbbreviationErrorCheck(c,a,typ,errmess) == - siz := SIZE (s := PNAME a) - if typ = 'category and siz > 7 - then throwKeyedErrorMsg('precompilation,"S2IL0021",NIL) - if siz > 8 then throwKeyedErrorMsg('precompilation,"S2IL0006",NIL) - if s ^= UPCASE s then throwKeyedMsg("S2IL0006",NIL) - abb := GETDATABASE(c,'ABBREVIATION) - name:= GETDATABASE(a,'CONSTRUCTOR) - type := GETDATABASE(c,'CONSTRUCTORKIND) - a=abb and c^=name => lisplibError(c,a,typ,abb,name,type,'duplicateAbb) - a=name and c^=name => lisplibError(c,a,typ,abb,name,type,'abbIsName) - c=name and typ^=type => lisplibError(c,a,typ,abb,name,type,'wrongType) - -abbreviationError(c,a,typ,abb,name,type,error) == - sayKeyedMsg("S2IL0009",[a,typ,c]) - error='duplicateAbb => - throwKeyedMsg("S2IL0010",[a,typ,name]) - error='abbIsName => - throwKeyedMsg("S2IL0011",[a,type]) - error='wrongType => - throwKeyedMsg("S2IL0012",[c,type]) - NIL - -abbreviate u == - u is ['Union,:arglist] => - ['Union,:[abbreviate a for a in arglist]] - u is [op,:arglist] => - abb := constructor?(op) => - [abb,:condAbbrev(arglist,getPartialConstructorModemapSig(op))] - u - constructor?(u) or u - -unabbrev u == unabbrev1(u,nil) - -unabbrevAndLoad u == unabbrev1(u,true) - -isNameOfType x == - $doNotAddEmptyModeIfTrue:local:= true - (val := get(x,'value,$InteractiveFrame)) and - (domain := objMode val) and - domain in '((Mode) (Domain) (SubDomain (Domain))) => true - y := opOf unabbrev x - constructor? y - -unabbrev1(u,modeIfTrue) == - atom u => - modeIfTrue => - d:= isDomainValuedVariable u => u - a := abbreviation? u => - GETDATABASE(a,'NILADIC) => [a] - largs := ['_$EmptyMode for arg in - getPartialConstructorModemapSig(a)] - unabbrev1([u,:largs],modeIfTrue) - u - a:= abbreviation?(u) or u - GETDATABASE(a,'NILADIC) => [a] - a - [op,:arglist] := u - op = 'Join => ['Join, :[unabbrev1(x, modeIfTrue) for x in arglist]] - d:= isDomainValuedVariable op => - throwKeyedMsg("S2IL0013",[op,d]) - (r := unabbrevSpecialForms(op,arglist,modeIfTrue)) => r - (cname := abbreviation? op) or (constructor?(op) and (cname := op)) => - (r := unabbrevSpecialForms(cname,arglist,modeIfTrue)) => r - -- ??? if modeIfTrue then loadIfNecessary cname - [cname,:condUnabbrev(op,arglist, - getPartialConstructorModemapSig(cname),modeIfTrue)] - u - -unabbrevSpecialForms(op,arglist,modeIfTrue) == - op = 'Mapping => [op,:[unabbrev1(a,modeIfTrue) for a in arglist]] - op = 'Union => - [op,:[unabbrevUnionComponent(a,modeIfTrue) for a in arglist]] - op = 'Record => - [op,:[unabbrevRecordComponent(a,modeIfTrue) for a in arglist]] - nil - -unabbrevRecordComponent(a,modeIfTrue) == - a is ["Declare",b,T] or a is [":",b,T] => - [":",b,unabbrev1(T,modeIfTrue)] - userError "wrong format for Record type" - -unabbrevUnionComponent(a,modeIfTrue) == - a is ["Declare",b,T] or a is [":",b,T] => - [":",b,unabbrev1(T,modeIfTrue)] - unabbrev1(a, modeIfTrue) - -condAbbrev(arglist,argtypes) == - res:= nil - for arg in arglist for type in argtypes repeat - if categoryForm?(type) then arg:= abbreviate arg - res:=[:res,arg] - res - -condUnabbrev(op,arglist,argtypes,modeIfTrue) == - #arglist ^= #argtypes => - throwKeyedMsg("S2IL0014",[op,plural(#argtypes,'"argument"), - bright(#arglist)]) - [newArg for arg in arglist for type in argtypes] where newArg() == - categoryForm?(type) => unabbrev1(arg,modeIfTrue) - arg - ---% Code Being Phased Out - -nAssocQ(x,l,n) == - repeat - if atom l then return nil - if EQ(x,(QCAR l).n) then return QCAR l - l:= QCDR l - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/g-error.boot b/src/interp/g-error.boot new file mode 100644 index 00000000..fe81ea1c --- /dev/null +++ b/src/interp/g-error.boot @@ -0,0 +1,202 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- 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. + + +import '"diagnostics" +import '"g-util" +)package "BOOT" + +-- This file contains the error printing code used in BOOT and SPAD. +-- While SPAD only calls "error" (which is then labeled as an algebra +-- error, BOOT calls "userError" and "systemError" when a problem is +-- found. +-- +-- The variable $BreakMode is set using the system command )set breakmode +-- and can have one of the values: +-- break -- always enter a lisp break when an error is signalled +-- nobreak -- do not enter lisp break mode +-- query -- ask the user if break mode should be entered + +$SystemError == 'SystemError +$UserError == 'UserError +$AlgebraError =='AlgebraError + +-- REDERR is used in BFLOAT LISP, should be a macro +-- REDERR msg == error msg + +-- BFLERRMSG func == +-- errorSupervisor($AlgebraError,STRCONC( +-- '"BigFloat: invalid argument to ",func)) + +argumentDataError(argnum, condit, funname) == + msg := ['"The test",:bright pred2English condit,'"evaluates to", + :bright '"false",'%l,'" for argument",:bright argnum,_ + '"to the function",:bright funname,'"and this indicates",'%l,_ + '" that the argument is not appropriate."] + errorSupervisor($AlgebraError,msg) + +queryUser msg == + -- display message and return reply + sayBrightly msg + read_-line _*TERMINAL_-IO_* + +-- errorSupervisor is the old style error message trapper + +errorSupervisor(errorType,errorMsg) == + errorSupervisor1(errorType,errorMsg,$BreakMode) + +errorSupervisor1(errorType,errorMsg,$BreakMode) == + $cclSystem and $BreakMode = 'trapNumerics => + THROW('trapNumerics,$numericFailure) + BUMPERRORCOUNT "semantic" + errorLabel := + errorType = $SystemError => '"System error" + errorType = $UserError => '"Apparent user error" + errorType = $AlgebraError => + '"Error detected within library code" + STRINGP errorType => errorType + '"Error with unknown classification" + msg := + errorMsg is ['mathprint, :.] => errorMsg + not PAIRP errorMsg => ['" ", errorMsg] + splitmsg := true + if member('%b,errorMsg) then splitmsg := nil + else if member('%d,errorMsg) then splitmsg := nil + else if member('%l,errorMsg) then splitmsg := nil + splitmsg => CDR [:['%l,'" ",u] for u in errorMsg] + ['" ",:errorMsg] + sayErrorly(errorLabel, msg) + handleLispBreakLoop($BreakMode) + +handleLispBreakLoop($BreakMode) == + TERPRI() + -- The next line is to try to deal with some reported cases of unwanted + -- backtraces appearing, MCD. + ENABLE_-BACKTRACE(nil) + $BreakMode = 'break => + sayBrightly '" " + BREAK() + $BreakMode = 'query => + gotIt := nil + while not gotIt repeat + gotIt := true + msgQ := + $cclSystem => + ['%l,'" You have two options. Enter:",'%l,_ + '" ",:bright '"top ",'" to return to top level, or",'%l,_ + '" ",:bright '"break ",'" to enter a LISP break loop.",'%l,_ + '%l,'" Please enter your choice now:"] + ['%l,'" You have three options. Enter:",'%l,_ + '" ",:bright '"continue",'" to continue processing,",'%l,_ + '" ",:bright '"top ",'" to return to top level, or",'%l,_ + '" ",:bright '"break ",'" to enter a LISP break loop.",'%l,_ + '%l,'" Please enter your choice now:"] + x := STRING2ID_-N(queryUser msgQ,1) + x := + $cclSystem => + selectOptionLC(x,'(top break),NIL) + selectOptionLC(x,'(top break continue),NIL) + null x => + sayBrightly bright '" That was not one of your choices!" + gotIt := NIL + x = 'top => returnToTopLevel() + x = 'break => + $BreakMode := 'break + if not $cclSystem then + sayBrightly ['" Enter",:bright '":C", + '"when you are ready to continue processing where you ",'%l,_ + '" interrupted the system, enter",:bright '"(TOP)",_ + '"when you wish to return",'%l,'" to top level.",'%l,'%l] + BREAK() + sayBrightly + '" Processing will continue where it was interrupted." + THROW('SPAD__READER, nil) + $BreakMode = 'resume => + returnToReader() + returnToTopLevel() + +TOP() == returnToTopLevel() + +returnToTopLevel() == + SETQ(CHR, "ENDOFLINECHR") + SETQ(TOK, 'END__UNIT) + TOPLEVEL() + +returnToReader() == + ^$ReadingFile => returnToTopLevel() + sayBrightly ['" Continuing to read the file...", '%l] + THROW('SPAD__READER, nil) + +sayErrorly(errorLabel, msg) == + $saturn => saturnSayErrorly(errorLabel, msg) + sayErrorly1(errorLabel, msg) + +saturnSayErrorly(errorLabel, msg) == + SETQ(_*STANDARD_-OUTPUT_*, $texOutputStream) + old := pushSatOutput("line") + sayString '"\bgroup\color{red}" + sayString '"\begin{verbatim}" + sayErrorly1(errorLabel, msg) + sayString '"\end{verbatim}" + sayString '"\egroup" + popSatOutput(old) + +sayErrorly1(errorLabel, msg) == + sayBrightly '" " + if $testingSystem then sayMSG $testingErrorPrefix + sayBrightly ['" >> ",errorLabel,'":"] + m := msg + msg is ['mathprint, mathexpr] => + mathprint mathexpr + sayBrightly msg + +-- systemError is being phased out. Please use keyedSystemError. +systemError(:x) == errorSupervisor($SystemError,IFCAR x) + +-- unexpectedSystemError() == +-- systemError '"Oh, no. Unexpected internal error." + +userError x == errorSupervisor($UserError,x) + +error(x) == errorSupervisor($AlgebraError,x) + +IdentityError(op) == + error(["No identity element for reduce of empty list using operation",op]) + +throwMessage(:msg) == + if $compilingMap then clearCache $mapName + msg' := mkMessage concatList msg + sayMSG msg' + if $printMsgsToFile then sayMSG2File msg' + spadThrow() + diff --git a/src/interp/g-error.boot.pamphlet b/src/interp/g-error.boot.pamphlet deleted file mode 100644 index 35cd7ebb..00000000 --- a/src/interp/g-error.boot.pamphlet +++ /dev/null @@ -1,225 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/g-error.boot} Pamphlet} -\author{The Axiom Team} - -\begin{document} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\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. - -@ -<<*>>= -<> - -import '"diagnostics" -import '"g-util" -)package "BOOT" - --- This file contains the error printing code used in BOOT and SPAD. --- While SPAD only calls "error" (which is then labeled as an algebra --- error, BOOT calls "userError" and "systemError" when a problem is --- found. --- --- The variable $BreakMode is set using the system command )set breakmode --- and can have one of the values: --- break -- always enter a lisp break when an error is signalled --- nobreak -- do not enter lisp break mode --- query -- ask the user if break mode should be entered - -$SystemError == 'SystemError -$UserError == 'UserError -$AlgebraError =='AlgebraError - --- REDERR is used in BFLOAT LISP, should be a macro --- REDERR msg == error msg - --- BFLERRMSG func == --- errorSupervisor($AlgebraError,STRCONC( --- '"BigFloat: invalid argument to ",func)) - -argumentDataError(argnum, condit, funname) == - msg := ['"The test",:bright pred2English condit,'"evaluates to", - :bright '"false",'%l,'" for argument",:bright argnum,_ - '"to the function",:bright funname,'"and this indicates",'%l,_ - '" that the argument is not appropriate."] - errorSupervisor($AlgebraError,msg) - -queryUser msg == - -- display message and return reply - sayBrightly msg - read_-line _*TERMINAL_-IO_* - --- errorSupervisor is the old style error message trapper - -errorSupervisor(errorType,errorMsg) == - errorSupervisor1(errorType,errorMsg,$BreakMode) - -errorSupervisor1(errorType,errorMsg,$BreakMode) == - $cclSystem and $BreakMode = 'trapNumerics => - THROW('trapNumerics,$numericFailure) - BUMPERRORCOUNT "semantic" - errorLabel := - errorType = $SystemError => '"System error" - errorType = $UserError => '"Apparent user error" - errorType = $AlgebraError => - '"Error detected within library code" - STRINGP errorType => errorType - '"Error with unknown classification" - msg := - errorMsg is ['mathprint, :.] => errorMsg - not PAIRP errorMsg => ['" ", errorMsg] - splitmsg := true - if member('%b,errorMsg) then splitmsg := nil - else if member('%d,errorMsg) then splitmsg := nil - else if member('%l,errorMsg) then splitmsg := nil - splitmsg => CDR [:['%l,'" ",u] for u in errorMsg] - ['" ",:errorMsg] - sayErrorly(errorLabel, msg) - handleLispBreakLoop($BreakMode) - -handleLispBreakLoop($BreakMode) == - TERPRI() - -- The next line is to try to deal with some reported cases of unwanted - -- backtraces appearing, MCD. - ENABLE_-BACKTRACE(nil) - $BreakMode = 'break => - sayBrightly '" " - BREAK() - $BreakMode = 'query => - gotIt := nil - while not gotIt repeat - gotIt := true - msgQ := - $cclSystem => - ['%l,'" You have two options. Enter:",'%l,_ - '" ",:bright '"top ",'" to return to top level, or",'%l,_ - '" ",:bright '"break ",'" to enter a LISP break loop.",'%l,_ - '%l,'" Please enter your choice now:"] - ['%l,'" You have three options. Enter:",'%l,_ - '" ",:bright '"continue",'" to continue processing,",'%l,_ - '" ",:bright '"top ",'" to return to top level, or",'%l,_ - '" ",:bright '"break ",'" to enter a LISP break loop.",'%l,_ - '%l,'" Please enter your choice now:"] - x := STRING2ID_-N(queryUser msgQ,1) - x := - $cclSystem => - selectOptionLC(x,'(top break),NIL) - selectOptionLC(x,'(top break continue),NIL) - null x => - sayBrightly bright '" That was not one of your choices!" - gotIt := NIL - x = 'top => returnToTopLevel() - x = 'break => - $BreakMode := 'break - if not $cclSystem then - sayBrightly ['" Enter",:bright '":C", - '"when you are ready to continue processing where you ",'%l,_ - '" interrupted the system, enter",:bright '"(TOP)",_ - '"when you wish to return",'%l,'" to top level.",'%l,'%l] - BREAK() - sayBrightly - '" Processing will continue where it was interrupted." - THROW('SPAD__READER, nil) - $BreakMode = 'resume => - returnToReader() - returnToTopLevel() - -TOP() == returnToTopLevel() - -returnToTopLevel() == - SETQ(CHR, "ENDOFLINECHR") - SETQ(TOK, 'END__UNIT) - TOPLEVEL() - -returnToReader() == - ^$ReadingFile => returnToTopLevel() - sayBrightly ['" Continuing to read the file...", '%l] - THROW('SPAD__READER, nil) - -sayErrorly(errorLabel, msg) == - $saturn => saturnSayErrorly(errorLabel, msg) - sayErrorly1(errorLabel, msg) - -saturnSayErrorly(errorLabel, msg) == - SETQ(_*STANDARD_-OUTPUT_*, $texOutputStream) - old := pushSatOutput("line") - sayString '"\bgroup\color{red}" - sayString '"\begin{verbatim}" - sayErrorly1(errorLabel, msg) - sayString '"\end{verbatim}" - sayString '"\egroup" - popSatOutput(old) - -sayErrorly1(errorLabel, msg) == - sayBrightly '" " - if $testingSystem then sayMSG $testingErrorPrefix - sayBrightly ['" >> ",errorLabel,'":"] - m := msg - msg is ['mathprint, mathexpr] => - mathprint mathexpr - sayBrightly msg - --- systemError is being phased out. Please use keyedSystemError. -systemError(:x) == errorSupervisor($SystemError,IFCAR x) - --- unexpectedSystemError() == --- systemError '"Oh, no. Unexpected internal error." - -userError x == errorSupervisor($UserError,x) - -error(x) == errorSupervisor($AlgebraError,x) - -IdentityError(op) == - error(["No identity element for reduce of empty list using operation",op]) - -throwMessage(:msg) == - if $compilingMap then clearCache $mapName - msg' := mkMessage concatList msg - sayMSG msg' - if $printMsgsToFile then sayMSG2File msg' - spadThrow() - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/g-opt.boot b/src/interp/g-opt.boot new file mode 100644 index 00000000..ed80cc90 --- /dev/null +++ b/src/interp/g-opt.boot @@ -0,0 +1,401 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- 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. + + +import '"def" + +)package "BOOT" + +--% OPTIMIZER + +optimizeFunctionDef(def) == + if $reportOptimization then + sayBrightlyI bright '"Original LISP code:" + pp def + + def' := optimize COPY def + + if $reportOptimization then + sayBrightlyI bright '"Optimized LISP code:" + pp def' + sayBrightlyI bright '"Final LISP code:" + [name,[slamOrLam,args,body]] := def' + + body':= + removeTopLevelCatch body where + removeTopLevelCatch body == + body is ["CATCH",g,u] => + removeTopLevelCatch replaceThrowByReturn(u,g) + body + replaceThrowByReturn(x,g) == + fn(x,g) + x + fn(x,g) == + x is ["THROW", =g,:u] => + rplac(first x,"RETURN") + rplac(rest x,replaceThrowByReturn(u,g)) + atom x => nil + replaceThrowByReturn(first x,g) + replaceThrowByReturn(rest x,g) + [name,[slamOrLam,args,body']] + +optimize x == + (opt x; x) where + opt x == + atom x => nil + (y:= first x)='QUOTE => nil + y='CLOSEDFN => nil + y is [["XLAM",argl,body],:a] => + optimize rest x + argl = "ignore" => RPLAC(first x,body) + if not (LENGTH argl<=LENGTH a) then + SAY '"length mismatch in XLAM expression" + PRETTYPRINT y + RPLAC(first x,optimize optXLAMCond SUBLIS(pairList(argl,a),body)) + atom y => + optimize rest x + y="true" => RPLAC(first x,'(QUOTE (QUOTE T))) + y="false" => RPLAC(first x,nil) + if first y="IF" then (RPLAC(first x,optIF2COND y); y:= first x) + op:= GETL(subrname first y,"OPTIMIZE") => + (optimize rest x; RPLAC(first x,FUNCALL(op,optimize first x))) + RPLAC(first x,optimize first x) + optimize rest x + +subrname u == + IDENTP u => u + COMPILED_-FUNCTION_-P u or MBPIP u => BPINAME u + nil + +optCatch (x is ["CATCH",g,a]) == + $InteractiveMode => x + atom a => a + if a is ["SEQ",:s,["THROW", =g,u]] then + changeThrowToExit(s,g) where + changeThrowToExit(s,g) == + atom s or MEMQ(first s,'(QUOTE SEQ REPEAT COLLECT)) => nil + s is ["THROW", =g,:u] => (rplac(first s,"EXIT"); rplac(rest s,u)) + changeThrowToExit(first s,g) + changeThrowToExit(rest s,g) + rplac(rest a,[:s,["EXIT",u]]) + ["CATCH",y,a]:= optimize x + if hasNoThrows(a,g) where + hasNoThrows(a,g) == + a is ["THROW", =g,:.] => false + atom a => true + hasNoThrows(first a,g) and hasNoThrows(rest a,g) + then (rplac(first x,first a); rplac(rest x,rest a)) + else + changeThrowToGo(a,g) where + changeThrowToGo(s,g) == + atom s or first s='QUOTE => nil + s is ["THROW", =g,u] => + changeThrowToGo(u,g) + rplac(first s,"PROGN") + rplac(rest s,[["LET",CADR g,u],["GO",CADR g]]) + changeThrowToGo(first s,g) + changeThrowToGo(rest s,g) + rplac(first x,"SEQ") + rplac(rest x,[["EXIT",a],CADR g,["EXIT",CADR g]]) + x + +optSPADCALL(form is ['SPADCALL,:argl]) == + null $InteractiveMode => form + -- last arg is function/env, but may be a form + argl is [:argl,fun] => + fun is ['ELT,dom,slot] or fun is ['LISPELT,dom,slot] => + optCall ['call,['ELT,dom,slot],:argl] + form + form + +optCall (x is ["call",:u]) == + -- destructively optimizes this new x + x:= optimize [u] + -- next should happen only as result of macro expansion + atom first x => first x + [fn,:a]:= first x + atom fn => (RPLAC(rest x,a); RPLAC(first x,fn)) + fn is ["PAC",:.] => optPackageCall(x,fn,a) + fn is ["applyFun",name] => + (RPLAC(first x,"SPADCALL"); RPLAC(rest x,[:a,name]); x) + fn is [q,R,n] and MEMQ(q,'(ELT QREFELT CONST)) => + not $bootStrapMode and (w:= optCallSpecially(q,x,n,R)) => w + q="CONST" => +--+ + ["spadConstant",R,n] + --putInLocalDomainReferences will change this to ELT or QREFELT + RPLAC(first x,"SPADCALL") + if $QuickCode then RPLACA(fn,"QREFELT") + RPLAC(rest x,[:a,fn]) + x + systemErrorHere '"optCall" + +optCallSpecially(q,x,n,R) == + y:= LASSOC(R,$specialCaseKeyList) => optSpecialCall(x,y,n) + MEMQ(KAR R,$optimizableConstructorNames) => optSpecialCall(x,R,n) + (y:= get(R,"value",$e)) and + MEMQ(opOf y.expr,$optimizableConstructorNames) => + optSpecialCall(x,y.expr,n) + ( + (y:= lookup(R,$getDomainCode)) and ([op,y,prop]:= y) and + (yy:= LASSOC(y,$specialCaseKeyList)) => + optSpecialCall(x,[op,yy,prop],n)) where + lookup(a,l) == + null l => nil + [l',:l]:= l + l' is ["LET", =a,l',:.] => l' + lookup(a,l) + nil + +optCallEval u == + u is ["List",:.] => List Integer() + u is ["Vector",:.] => Vector Integer() + u is ["PrimitiveArray",:.] => PrimitiveArray Integer() + u is ["FactoredForm",:.] => FactoredForm Integer() + u is ["Matrix",:.] => Matrix Integer() + eval u + +optCons (x is ["CONS",a,b]) == + a="NIL" => + b='NIL => (rplac(first x,'QUOTE); rplac(rest x,['NIL,:'NIL]); x) + b is ['QUOTE,:c] => (rplac(first x,'QUOTE); rplac(rest x,['NIL,:c]); x) + x + a is ['QUOTE,a'] => + b='NIL => (rplac(first x,'QUOTE); rplac(rest x,[a',:'NIL]); x) + b is ['QUOTE,:c] => (rplac(first x,'QUOTE); rplac(rest x,[a',:c]); x) + x + x + +optSpecialCall(x,y,n) == + yval := optCallEval y + CAAAR x="CONST" => + KAR yval.n = function Undef => + keyedSystemError("S2GE0016",['"optSpecialCall", + '"invalid constant"]) + MKQ yval.n + fn := GETL(compileTimeBindingOf first yval.n,'SPADreplace) => + rplac(rest x,CDAR x) + rplac(first x,fn) + if fn is ["XLAM",:.] then x:=first optimize [x] + x is ["EQUAL",:args] => RPLACW(x,DEF_-EQUAL args) + --DEF-EQUAL is really an optimiser + x + [fn,:a]:= first x + RPLAC(first x,"SPADCALL") + if $QuickCode then RPLACA(fn,"QREFELT") + RPLAC(rest x,[:a,fn]) + x + +compileTimeBindingOf u == + NULL(name:= BPINAME u) => keyedSystemError("S2OO0001",[u]) + name="Undef" => MOAN "optimiser found unknown function" + name + +optMkRecord ["mkRecord",:u] == + u is [x] => ["LIST",x] + #u=2 => ["CONS",:u] + ["VECTOR",:u] + +optCond (x is ['COND,:l]) == + if l is [a,[aa,b]] and TruthP aa and b is ["COND",:c] then + RPLACD(rest x,c) + if l is [[p1,:c1],[p2,:c2],:.] then + if (p1 is ['NULL,p1'] and p1' = p2) or (p2 is ['NULL,p2'] and p2' = p1) then + l:=[[p1,:c1],['(QUOTE T),:c2]] + RPLACD( x,l) + c1 is ['NIL] and p2 = '(QUOTE T) and first c2 = '(QUOTE T) => + p1 is ['NULL,p1']=> return p1' + return ['NULL,p1] + l is [[p1,:c1],[p2,:c2],[p3,:c3]] and TruthP p3 => + EqualBarGensym(c1,c3) => + ["COND",[["OR",p1,["NULL",p2]],:c1],[['QUOTE,true],:c2]] + EqualBarGensym(c1,c2) => ["COND",[["OR",p1,p2],:c1],[['QUOTE,true],:c3]] + x + for y in tails l repeat + while y is [[a1,c1],[a2,c2],:y'] and EqualBarGensym(c1,c2) repeat + a:=['OR,a1,a2] + RPLAC(first first y,a) + RPLAC(rest y,y') + x + +AssocBarGensym(key,l) == + for x in l repeat + PAIRP x => + EqualBarGensym(key,CAR x) => return x + +EqualBarGensym(x,y) == + $GensymAssoc: fluid + fn(x,y) where + fn(x,y) == + x=y => true + GENSYMP x and GENSYMP y => + z:= assoc(x,$GensymAssoc) => (y=rest z => true; false) + $GensymAssoc:= [[x,:y],:$GensymAssoc] + true + null x => y is [g] and GENSYMP g + null y => x is [g] and GENSYMP g + atom x or atom y => false + fn(first x,first y) and fn(rest x,rest y) + +--Called early, to change IF to COND + +optIF2COND ["IF",a,b,c] == + b is "noBranch" => ["COND",[["NULL",a],c]] + c is "noBranch" => ["COND",[a,b]] + c is ["IF",:.] => ["COND",[a,b],:rest optIF2COND c] + c is ["COND",:p] => ["COND",[a,b],:p] + ["COND",[a,b],[$true,c]] + +optXLAMCond x == + x is ["COND",u:= [p,c],:l] => + (optPredicateIfTrue p => c; ["COND",u,:optCONDtail l]) + atom x => x + RPLAC(first x,optXLAMCond first x) + RPLAC(rest x,optXLAMCond rest x) + x + +optPredicateIfTrue p == + p is ['QUOTE,:.] => true + p is [fn,x] and MEMQ(fn,$BasicPredicates) and FUNCALL(fn,x) => true + nil + +optCONDtail l == + null l => nil + [frst:= [p,c],:l']:= l + optPredicateIfTrue p => [[$true,c]] + null rest l => [frst,[$true,["CondError"]]] + [frst,:optCONDtail l'] + +optSEQ ["SEQ",:l] == + tryToRemoveSEQ SEQToCOND getRidOfTemps l where + getRidOfTemps l == + null l => nil + l is [["LET",g,x,:.],:r] and GENSYMP g and 2>numOfOccurencesOf(g,r) => + getRidOfTemps substitute(x,g,r) + first l="/throwAway" => getRidOfTemps rest l + --this gets rid of unwanted labels generated by declarations in SEQs + [first l,:getRidOfTemps rest l] + SEQToCOND l == + transform:= [[a,b] for x in l while (x is ["COND",[a,["EXIT",b]]])] + before:= take(#transform,l) + aft:= after(l,before) + null before => ["SEQ",:aft] + null aft => ["COND",:transform,'((QUOTE T) (conderr))] + true => ["COND",:transform,['(QUOTE T),optSEQ ["SEQ",:aft]]] + tryToRemoveSEQ l == + l is ["SEQ",[op,a]] and MEMQ(op,'(EXIT RETURN THROW)) => a + l + +optRECORDELT ["RECORDELT",name,ind,len] == + len=1 => + ind=0 => ["QCAR",name] + keyedSystemError("S2OO0002",[ind]) + len=2 => + ind=0 => ["QCAR",name] + ind=1 => ["QCDR",name] + keyedSystemError("S2OO0002",[ind]) + ["QVELT",name,ind] + +optSETRECORDELT ["SETRECORDELT",name,ind,len,expr] == + len=1 => + ind=0 => ["PROGN",["RPLACA",name,expr],["QCAR",name]] + keyedSystemError("S2OO0002",[ind]) + len=2 => + ind=0 => ["PROGN",["RPLACA",name,expr],["QCAR",name]] + ind=1 => ["PROGN",["RPLACD",name,expr],["QCDR",name]] + keyedSystemError("S2OO0002",[ind]) + ["QSETVELT",name,ind,expr] + +optRECORDCOPY ["RECORDCOPY",name,len] == + len=1 => ["LIST",["CAR",name]] + len=2 => ["CONS",["CAR",name],["CDR",name]] + ["MOVEVEC",["MAKE_-VEC",len],name] + +--mkRecordAccessFunction(ind,len) == +-- stringOfDs:= $EmptyString +-- for i in 0..(ind-1) do stringOfDs:= STRCONC(stringOfDs,PNAME "D") +-- prefix:= if ind=len-1 then PNAME "C" else PNAME "CA" +-- if $QuickCode then prefix:=STRCONC("Q",prefix) +-- INTERN(STRCONC(prefix,stringOfDs,PNAME "R")) + +optSuchthat [.,:u] == ["SUCHTHAT",:u] + +optMINUS u == + u is ['MINUS,v] => + NUMBERP v => -v + u + u + +optQSMINUS u == + u is ['QSMINUS,v] => + NUMBERP v => -v + u + u + +opt_- u == + u is ['_-,v] => + NUMBERP v => -v + u + u + +optLESSP u == + u is ['LESSP,a,b] => + b = 0 => ['MINUSP,a] + ['GREATERP,b,a] + u + +optEQ u == + u is ['EQ,l,r] => + NUMBERP l and NUMBERP r => ['QUOTE,EQ(l,r)] + -- That undoes some weird work in Boolean to do with the definition of true + u + u + +for x in '( (call optCall) _ + (SEQ optSEQ)_ + (EQ optEQ) + (MINUS optMINUS)_ + (QSMINUS optQSMINUS)_ + (_- opt_-)_ + (LESSP optLESSP)_ + (SPADCALL optSPADCALL)_ + (_| optSuchthat)_ + (CATCH optCatch)_ + (COND optCond)_ + (mkRecord optMkRecord)_ + (RECORDELT optRECORDELT)_ + (SETRECORDELT optSETRECORDELT)_ + (RECORDCOPY optRECORDCOPY)) _ + repeat MAKEPROP(CAR x,'OPTIMIZE,CREATE_-SBC CADR x) + --much quicker to call functions if they have an SBC + diff --git a/src/interp/g-opt.boot.pamphlet b/src/interp/g-opt.boot.pamphlet deleted file mode 100644 index f45a5378..00000000 --- a/src/interp/g-opt.boot.pamphlet +++ /dev/null @@ -1,421 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp g-opt.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\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. - -@ -<<*>>= -<> - -import '"def" - -)package "BOOT" - ---% OPTIMIZER - -optimizeFunctionDef(def) == - if $reportOptimization then - sayBrightlyI bright '"Original LISP code:" - pp def - - def' := optimize COPY def - - if $reportOptimization then - sayBrightlyI bright '"Optimized LISP code:" - pp def' - sayBrightlyI bright '"Final LISP code:" - [name,[slamOrLam,args,body]] := def' - - body':= - removeTopLevelCatch body where - removeTopLevelCatch body == - body is ["CATCH",g,u] => - removeTopLevelCatch replaceThrowByReturn(u,g) - body - replaceThrowByReturn(x,g) == - fn(x,g) - x - fn(x,g) == - x is ["THROW", =g,:u] => - rplac(first x,"RETURN") - rplac(rest x,replaceThrowByReturn(u,g)) - atom x => nil - replaceThrowByReturn(first x,g) - replaceThrowByReturn(rest x,g) - [name,[slamOrLam,args,body']] - -optimize x == - (opt x; x) where - opt x == - atom x => nil - (y:= first x)='QUOTE => nil - y='CLOSEDFN => nil - y is [["XLAM",argl,body],:a] => - optimize rest x - argl = "ignore" => RPLAC(first x,body) - if not (LENGTH argl<=LENGTH a) then - SAY '"length mismatch in XLAM expression" - PRETTYPRINT y - RPLAC(first x,optimize optXLAMCond SUBLIS(pairList(argl,a),body)) - atom y => - optimize rest x - y="true" => RPLAC(first x,'(QUOTE (QUOTE T))) - y="false" => RPLAC(first x,nil) - if first y="IF" then (RPLAC(first x,optIF2COND y); y:= first x) - op:= GETL(subrname first y,"OPTIMIZE") => - (optimize rest x; RPLAC(first x,FUNCALL(op,optimize first x))) - RPLAC(first x,optimize first x) - optimize rest x - -subrname u == - IDENTP u => u - COMPILED_-FUNCTION_-P u or MBPIP u => BPINAME u - nil - -optCatch (x is ["CATCH",g,a]) == - $InteractiveMode => x - atom a => a - if a is ["SEQ",:s,["THROW", =g,u]] then - changeThrowToExit(s,g) where - changeThrowToExit(s,g) == - atom s or MEMQ(first s,'(QUOTE SEQ REPEAT COLLECT)) => nil - s is ["THROW", =g,:u] => (rplac(first s,"EXIT"); rplac(rest s,u)) - changeThrowToExit(first s,g) - changeThrowToExit(rest s,g) - rplac(rest a,[:s,["EXIT",u]]) - ["CATCH",y,a]:= optimize x - if hasNoThrows(a,g) where - hasNoThrows(a,g) == - a is ["THROW", =g,:.] => false - atom a => true - hasNoThrows(first a,g) and hasNoThrows(rest a,g) - then (rplac(first x,first a); rplac(rest x,rest a)) - else - changeThrowToGo(a,g) where - changeThrowToGo(s,g) == - atom s or first s='QUOTE => nil - s is ["THROW", =g,u] => - changeThrowToGo(u,g) - rplac(first s,"PROGN") - rplac(rest s,[["LET",CADR g,u],["GO",CADR g]]) - changeThrowToGo(first s,g) - changeThrowToGo(rest s,g) - rplac(first x,"SEQ") - rplac(rest x,[["EXIT",a],CADR g,["EXIT",CADR g]]) - x - -optSPADCALL(form is ['SPADCALL,:argl]) == - null $InteractiveMode => form - -- last arg is function/env, but may be a form - argl is [:argl,fun] => - fun is ['ELT,dom,slot] or fun is ['LISPELT,dom,slot] => - optCall ['call,['ELT,dom,slot],:argl] - form - form - -optCall (x is ["call",:u]) == - -- destructively optimizes this new x - x:= optimize [u] - -- next should happen only as result of macro expansion - atom first x => first x - [fn,:a]:= first x - atom fn => (RPLAC(rest x,a); RPLAC(first x,fn)) - fn is ["PAC",:.] => optPackageCall(x,fn,a) - fn is ["applyFun",name] => - (RPLAC(first x,"SPADCALL"); RPLAC(rest x,[:a,name]); x) - fn is [q,R,n] and MEMQ(q,'(ELT QREFELT CONST)) => - not $bootStrapMode and (w:= optCallSpecially(q,x,n,R)) => w - q="CONST" => ---+ - ["spadConstant",R,n] - --putInLocalDomainReferences will change this to ELT or QREFELT - RPLAC(first x,"SPADCALL") - if $QuickCode then RPLACA(fn,"QREFELT") - RPLAC(rest x,[:a,fn]) - x - systemErrorHere '"optCall" - -optCallSpecially(q,x,n,R) == - y:= LASSOC(R,$specialCaseKeyList) => optSpecialCall(x,y,n) - MEMQ(KAR R,$optimizableConstructorNames) => optSpecialCall(x,R,n) - (y:= get(R,"value",$e)) and - MEMQ(opOf y.expr,$optimizableConstructorNames) => - optSpecialCall(x,y.expr,n) - ( - (y:= lookup(R,$getDomainCode)) and ([op,y,prop]:= y) and - (yy:= LASSOC(y,$specialCaseKeyList)) => - optSpecialCall(x,[op,yy,prop],n)) where - lookup(a,l) == - null l => nil - [l',:l]:= l - l' is ["LET", =a,l',:.] => l' - lookup(a,l) - nil - -optCallEval u == - u is ["List",:.] => List Integer() - u is ["Vector",:.] => Vector Integer() - u is ["PrimitiveArray",:.] => PrimitiveArray Integer() - u is ["FactoredForm",:.] => FactoredForm Integer() - u is ["Matrix",:.] => Matrix Integer() - eval u - -optCons (x is ["CONS",a,b]) == - a="NIL" => - b='NIL => (rplac(first x,'QUOTE); rplac(rest x,['NIL,:'NIL]); x) - b is ['QUOTE,:c] => (rplac(first x,'QUOTE); rplac(rest x,['NIL,:c]); x) - x - a is ['QUOTE,a'] => - b='NIL => (rplac(first x,'QUOTE); rplac(rest x,[a',:'NIL]); x) - b is ['QUOTE,:c] => (rplac(first x,'QUOTE); rplac(rest x,[a',:c]); x) - x - x - -optSpecialCall(x,y,n) == - yval := optCallEval y - CAAAR x="CONST" => - KAR yval.n = function Undef => - keyedSystemError("S2GE0016",['"optSpecialCall", - '"invalid constant"]) - MKQ yval.n - fn := GETL(compileTimeBindingOf first yval.n,'SPADreplace) => - rplac(rest x,CDAR x) - rplac(first x,fn) - if fn is ["XLAM",:.] then x:=first optimize [x] - x is ["EQUAL",:args] => RPLACW(x,DEF_-EQUAL args) - --DEF-EQUAL is really an optimiser - x - [fn,:a]:= first x - RPLAC(first x,"SPADCALL") - if $QuickCode then RPLACA(fn,"QREFELT") - RPLAC(rest x,[:a,fn]) - x - -compileTimeBindingOf u == - NULL(name:= BPINAME u) => keyedSystemError("S2OO0001",[u]) - name="Undef" => MOAN "optimiser found unknown function" - name - -optMkRecord ["mkRecord",:u] == - u is [x] => ["LIST",x] - #u=2 => ["CONS",:u] - ["VECTOR",:u] - -optCond (x is ['COND,:l]) == - if l is [a,[aa,b]] and TruthP aa and b is ["COND",:c] then - RPLACD(rest x,c) - if l is [[p1,:c1],[p2,:c2],:.] then - if (p1 is ['NULL,p1'] and p1' = p2) or (p2 is ['NULL,p2'] and p2' = p1) then - l:=[[p1,:c1],['(QUOTE T),:c2]] - RPLACD( x,l) - c1 is ['NIL] and p2 = '(QUOTE T) and first c2 = '(QUOTE T) => - p1 is ['NULL,p1']=> return p1' - return ['NULL,p1] - l is [[p1,:c1],[p2,:c2],[p3,:c3]] and TruthP p3 => - EqualBarGensym(c1,c3) => - ["COND",[["OR",p1,["NULL",p2]],:c1],[['QUOTE,true],:c2]] - EqualBarGensym(c1,c2) => ["COND",[["OR",p1,p2],:c1],[['QUOTE,true],:c3]] - x - for y in tails l repeat - while y is [[a1,c1],[a2,c2],:y'] and EqualBarGensym(c1,c2) repeat - a:=['OR,a1,a2] - RPLAC(first first y,a) - RPLAC(rest y,y') - x - -AssocBarGensym(key,l) == - for x in l repeat - PAIRP x => - EqualBarGensym(key,CAR x) => return x - -EqualBarGensym(x,y) == - $GensymAssoc: fluid - fn(x,y) where - fn(x,y) == - x=y => true - GENSYMP x and GENSYMP y => - z:= assoc(x,$GensymAssoc) => (y=rest z => true; false) - $GensymAssoc:= [[x,:y],:$GensymAssoc] - true - null x => y is [g] and GENSYMP g - null y => x is [g] and GENSYMP g - atom x or atom y => false - fn(first x,first y) and fn(rest x,rest y) - ---Called early, to change IF to COND - -optIF2COND ["IF",a,b,c] == - b is "noBranch" => ["COND",[["NULL",a],c]] - c is "noBranch" => ["COND",[a,b]] - c is ["IF",:.] => ["COND",[a,b],:rest optIF2COND c] - c is ["COND",:p] => ["COND",[a,b],:p] - ["COND",[a,b],[$true,c]] - -optXLAMCond x == - x is ["COND",u:= [p,c],:l] => - (optPredicateIfTrue p => c; ["COND",u,:optCONDtail l]) - atom x => x - RPLAC(first x,optXLAMCond first x) - RPLAC(rest x,optXLAMCond rest x) - x - -optPredicateIfTrue p == - p is ['QUOTE,:.] => true - p is [fn,x] and MEMQ(fn,$BasicPredicates) and FUNCALL(fn,x) => true - nil - -optCONDtail l == - null l => nil - [frst:= [p,c],:l']:= l - optPredicateIfTrue p => [[$true,c]] - null rest l => [frst,[$true,["CondError"]]] - [frst,:optCONDtail l'] - -optSEQ ["SEQ",:l] == - tryToRemoveSEQ SEQToCOND getRidOfTemps l where - getRidOfTemps l == - null l => nil - l is [["LET",g,x,:.],:r] and GENSYMP g and 2>numOfOccurencesOf(g,r) => - getRidOfTemps substitute(x,g,r) - first l="/throwAway" => getRidOfTemps rest l - --this gets rid of unwanted labels generated by declarations in SEQs - [first l,:getRidOfTemps rest l] - SEQToCOND l == - transform:= [[a,b] for x in l while (x is ["COND",[a,["EXIT",b]]])] - before:= take(#transform,l) - aft:= after(l,before) - null before => ["SEQ",:aft] - null aft => ["COND",:transform,'((QUOTE T) (conderr))] - true => ["COND",:transform,['(QUOTE T),optSEQ ["SEQ",:aft]]] - tryToRemoveSEQ l == - l is ["SEQ",[op,a]] and MEMQ(op,'(EXIT RETURN THROW)) => a - l - -optRECORDELT ["RECORDELT",name,ind,len] == - len=1 => - ind=0 => ["QCAR",name] - keyedSystemError("S2OO0002",[ind]) - len=2 => - ind=0 => ["QCAR",name] - ind=1 => ["QCDR",name] - keyedSystemError("S2OO0002",[ind]) - ["QVELT",name,ind] - -optSETRECORDELT ["SETRECORDELT",name,ind,len,expr] == - len=1 => - ind=0 => ["PROGN",["RPLACA",name,expr],["QCAR",name]] - keyedSystemError("S2OO0002",[ind]) - len=2 => - ind=0 => ["PROGN",["RPLACA",name,expr],["QCAR",name]] - ind=1 => ["PROGN",["RPLACD",name,expr],["QCDR",name]] - keyedSystemError("S2OO0002",[ind]) - ["QSETVELT",name,ind,expr] - -optRECORDCOPY ["RECORDCOPY",name,len] == - len=1 => ["LIST",["CAR",name]] - len=2 => ["CONS",["CAR",name],["CDR",name]] - ["MOVEVEC",["MAKE_-VEC",len],name] - ---mkRecordAccessFunction(ind,len) == --- stringOfDs:= $EmptyString --- for i in 0..(ind-1) do stringOfDs:= STRCONC(stringOfDs,PNAME "D") --- prefix:= if ind=len-1 then PNAME "C" else PNAME "CA" --- if $QuickCode then prefix:=STRCONC("Q",prefix) --- INTERN(STRCONC(prefix,stringOfDs,PNAME "R")) - -optSuchthat [.,:u] == ["SUCHTHAT",:u] - -optMINUS u == - u is ['MINUS,v] => - NUMBERP v => -v - u - u - -optQSMINUS u == - u is ['QSMINUS,v] => - NUMBERP v => -v - u - u - -opt_- u == - u is ['_-,v] => - NUMBERP v => -v - u - u - -optLESSP u == - u is ['LESSP,a,b] => - b = 0 => ['MINUSP,a] - ['GREATERP,b,a] - u - -optEQ u == - u is ['EQ,l,r] => - NUMBERP l and NUMBERP r => ['QUOTE,EQ(l,r)] - -- That undoes some weird work in Boolean to do with the definition of true - u - u - -for x in '( (call optCall) _ - (SEQ optSEQ)_ - (EQ optEQ) - (MINUS optMINUS)_ - (QSMINUS optQSMINUS)_ - (_- opt_-)_ - (LESSP optLESSP)_ - (SPADCALL optSPADCALL)_ - (_| optSuchthat)_ - (CATCH optCatch)_ - (COND optCond)_ - (mkRecord optMkRecord)_ - (RECORDELT optRECORDELT)_ - (SETRECORDELT optSETRECORDELT)_ - (RECORDCOPY optRECORDCOPY)) _ - repeat MAKEPROP(CAR x,'OPTIMIZE,CREATE_-SBC CADR x) - --much quicker to call functions if they have an SBC - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/g-timer.boot b/src/interp/g-timer.boot new file mode 100644 index 00000000..0f26f306 --- /dev/null +++ b/src/interp/g-timer.boot @@ -0,0 +1,276 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- 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. + + +import '"macros" +import '"g-util" +)package "BOOT" + +--% Code instrumentation facilities +-- These functions can be used with arbitrary lists of +-- named stats (listofnames) grouped in classes (listofclasses) +-- and with measurement types (property, classproperty). + +printNamedStatsByProperty(listofnames, property) == + total := +/[GETL(name,property) for [name,:.] in listofnames] + for [name,:.] in listofnames repeat + n := GETL(name, property) + strname := STRINGIMAGE name + strval := STRINGIMAGE n + sayBrightly concat(bright strname, + fillerSpaces(70-#strname-#strval,'"."),bright strval) + sayBrightly bright fillerSpaces(72,'"-") + sayBrightly concat(bright '"Total", + fillerSpaces(65-# STRINGIMAGE total,'"."),bright STRINGIMAGE total) + +makeLongStatStringByProperty _ + (listofnames, listofclasses, property, classproperty, units, flag) == + total := 0 + str := '"" + otherStatTotal := GETL('other, property) + for [name,class,:ab] in listofnames repeat + name = 'other => 'iterate + cl := CAR LASSOC(class,listofclasses) + n := GETL( name, property) + PUT(cl,classproperty, n + GETL(cl,classproperty)) + total := total + n + if n >= 0.01 + then timestr := normalizeStatAndStringify n + else + timestr := '"" + otherStatTotal := otherStatTotal + n + str := makeStatString(str,timestr,ab,flag) + otherStatTotal := otherStatTotal + PUT('other, property, otherStatTotal) + if otherStatTotal > 0 then + str := makeStatString(str,normalizeStatAndStringify otherStatTotal,'O,flag) + total := total + otherStatTotal + cl := CAR LASSOC('other,listofnames) + cl := CAR LASSOC(cl,listofclasses) + PUT(cl,classproperty, otherStatTotal + GETL(cl,classproperty)) + if flag ^= 'long then + total := 0 + str := '"" + for [class,name,:ab] in listofclasses repeat + n := GETL(name, classproperty) + n = 0.0 => 'iterate + total := total + n + timestr := normalizeStatAndStringify n + str := makeStatString(str,timestr,ab,flag) + total := STRCONC(normalizeStatAndStringify total,'" ", units) + str = '"" => total + STRCONC(str, '" = ", total) + +normalizeStatAndStringify t == + RNUMP t => + t := roundStat t + t = 0.0 => '"0" + FORMAT(nil,'"~,2F",t) + INTP t => + K := 1024 + M := K*K + t > 9*M => CONCAT(STRINGIMAGE((t + 512*K)/M), '"M") + t > 9*K => CONCAT(STRINGIMAGE((t + 512)/K), '"K") + STRINGIMAGE t + STRINGIMAGE t + +significantStat t == + RNUMP t => (t > 0.01) + INTP t => (t > 100) + true + +roundStat t == + not RNUMP t => t + (FIX (0.5 + t * 1000.0)) / 1000.0 + +makeStatString(oldstr,time,abb,flag) == + time = '"" => oldstr + opening := (flag = 'long => '"("; '" (") + oldstr = '"" => STRCONC(time,opening,abb,'")") + STRCONC(oldstr,'" + ",time,opening,abb,'")") + +peekTimedName() == IFCAR $timedNameStack + +popTimedName() == + name := IFCAR $timedNameStack + $timedNameStack := IFCDR $timedNameStack + name + +pushTimedName name == + PUSH(name,$timedNameStack) + +--currentlyTimedName() == CAR $timedNameStack + +startTimingProcess name == + updateTimedName peekTimedName() + pushTimedName name + if EQ(name, 'load) then statRecordLoadEvent() + +stopTimingProcess name == + (name ^= peekTimedName()) and null $InteractiveMode => + keyedSystemError("S2GL0015",[name,peekTimedName()]) + updateTimedName peekTimedName() + popTimedName() + +--% Instrumentation specific to the interpreter +SETANDFILEQ($oldElapsedSpace, 0) +SETANDFILEQ($oldElapsedGCTime,0.0) +SETANDFILEQ($oldElapsedTime,0.0) +SETANDFILEQ($gcTimeTotal,0.0) + +-- $timedNameStack is used to hold the names of sections of the +-- code being timed. + +SETANDFILEQ($timedNameStack,'(other)) + +SETANDFILEQ($interpreterTimedNames,'( +-- name class abbrev + (algebra 2 . B) _ + (analysis 1 . A) _ + (coercion 1 . C) _ + (compilation 3 . T) _ + (debug 3 . D) _ + (evaluation 2 . E) _ + (gc 4 . G) _ + (history 3 . H) _ + (instantiation 3 . I) _ + (load 3 . L) _ + (modemaps 1 . M) _ + (optimization 3 . Z) _ + (querycoerce 1 . Q) _ + (other 3 . O) _ + (diskread 3 . K) _ + (print 3 . P) _ + (resolve 1 . R) _ + )) + +SETANDFILEQ($interpreterTimedClasses, '( +-- number class name short name + ( 1 interpreter . IN) _ + ( 2 evaluation . EV) _ + ( 3 other . OT) _ + ( 4 reclaim . GC) _ + )) + +initializeTimedNames(listofnames,listofclasses) == + for [name,:.] in listofnames repeat + PUT(name, 'TimeTotal, 0.0) + PUT(name, 'SpaceTotal, 0) + for [.,name,:.] in listofclasses repeat + PUT( name, 'ClassTimeTotal, 0.0) + PUT( name, 'ClassSpaceTotal, 0) + $timedNameStack := '(other) + computeElapsedTime() + PUT('gc, 'TimeTotal, 0.0) + PUT('gc, 'SpaceTotal, 0) + NIL + +updateTimedName name == + count := (GETL(name,'TimeTotal) or 0) + computeElapsedTime() + PUT(name,'TimeTotal, count) + +printNamedStats listofnames == + printNamedStatsByProperty(listofnames, 'TimeTotal) + sayBrightly '" " + sayBrightly '"Space (in bytes):" + printNamedStatsByProperty(listofnames, 'SpaceTotal) + +makeLongTimeString(listofnames,listofclasses) == + makeLongStatStringByProperty(listofnames, listofclasses, _ + 'TimeTotal, 'ClassTimeTotal, _ + '"sec", $printTimeIfTrue) + +makeLongSpaceString(listofnames,listofclasses) == + makeLongStatStringByProperty(listofnames, listofclasses, _ + 'SpaceTotal, 'ClassSpaceTotal, _ + '"bytes", $printStorageIfTrue) + +computeElapsedTime() == + -- in total time lists, CAR is VIRTCPU and CADR is TOTCPU + currentTime:= elapsedUserTime() + currentGCTime:= elapsedGcTime() + gcDelta := currentGCTime - $oldElapsedGCTime + elapsedSeconds:= + -- In CCL total time does not include GC time. + $cclSystem => 1.*(currentTime-$oldElapsedTime)/$timerTicksPerSecond + 1.*(currentTime-$oldElapsedTime-gcDelta)/$timerTicksPerSecond + PUT('gc, 'TimeTotal,GETL('gc,'TimeTotal) + + 1.*gcDelta/$timerTicksPerSecond) + $oldElapsedTime := elapsedUserTime() + $oldElapsedGCTime := elapsedGcTime() + elapsedSeconds + +computeElapsedSpace() == + currentElapsedSpace := HEAPELAPSED() + elapsedBytes := currentElapsedSpace - $oldElapsedSpace + $oldElapsedSpace := currentElapsedSpace + elapsedBytes + +timedAlgebraEvaluation(code) == + startTimingProcess 'algebra + r := eval code + stopTimingProcess 'algebra + r + +timedOptimization(code) == + startTimingProcess 'optimization + $getDomainCode : local := NIL + r := lispize code + if $reportOptimization then + sayBrightlyI bright '"Optimized LISP code:" + pp r + stopTimingProcess 'optimization + r + +timedEVALFUN(code) == + startTimingProcess 'evaluation + r := timedEvaluate code + stopTimingProcess 'evaluation + r + +timedEvaluate code == + code is ["LIST",:a] and #a > 200 => + "append"/[eval ["LIST",:x] for x in splitIntoBlocksOf200 a] + eval code + +displayHeapStatsIfWanted() == + $printStorageIfTrue => sayBrightly OLDHEAPSTATS() + +--EVALANDFILEACTQ( +-- PUTGCEXIT function displayHeapStatsIfWanted ) + +--% stubs for the stats summary fns +statRecordInstantiationEvent() == nil +statRecordLoadEvent() == nil + +statisticsSummary() == '"No statistics available." diff --git a/src/interp/g-timer.boot.pamphlet b/src/interp/g-timer.boot.pamphlet deleted file mode 100644 index 6b060ddc..00000000 --- a/src/interp/g-timer.boot.pamphlet +++ /dev/null @@ -1,296 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp g-timer.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\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. - -@ -<<*>>= -<> - -import '"macros" -import '"g-util" -)package "BOOT" - ---% Code instrumentation facilities --- These functions can be used with arbitrary lists of --- named stats (listofnames) grouped in classes (listofclasses) --- and with measurement types (property, classproperty). - -printNamedStatsByProperty(listofnames, property) == - total := +/[GETL(name,property) for [name,:.] in listofnames] - for [name,:.] in listofnames repeat - n := GETL(name, property) - strname := STRINGIMAGE name - strval := STRINGIMAGE n - sayBrightly concat(bright strname, - fillerSpaces(70-#strname-#strval,'"."),bright strval) - sayBrightly bright fillerSpaces(72,'"-") - sayBrightly concat(bright '"Total", - fillerSpaces(65-# STRINGIMAGE total,'"."),bright STRINGIMAGE total) - -makeLongStatStringByProperty _ - (listofnames, listofclasses, property, classproperty, units, flag) == - total := 0 - str := '"" - otherStatTotal := GETL('other, property) - for [name,class,:ab] in listofnames repeat - name = 'other => 'iterate - cl := CAR LASSOC(class,listofclasses) - n := GETL( name, property) - PUT(cl,classproperty, n + GETL(cl,classproperty)) - total := total + n - if n >= 0.01 - then timestr := normalizeStatAndStringify n - else - timestr := '"" - otherStatTotal := otherStatTotal + n - str := makeStatString(str,timestr,ab,flag) - otherStatTotal := otherStatTotal - PUT('other, property, otherStatTotal) - if otherStatTotal > 0 then - str := makeStatString(str,normalizeStatAndStringify otherStatTotal,'O,flag) - total := total + otherStatTotal - cl := CAR LASSOC('other,listofnames) - cl := CAR LASSOC(cl,listofclasses) - PUT(cl,classproperty, otherStatTotal + GETL(cl,classproperty)) - if flag ^= 'long then - total := 0 - str := '"" - for [class,name,:ab] in listofclasses repeat - n := GETL(name, classproperty) - n = 0.0 => 'iterate - total := total + n - timestr := normalizeStatAndStringify n - str := makeStatString(str,timestr,ab,flag) - total := STRCONC(normalizeStatAndStringify total,'" ", units) - str = '"" => total - STRCONC(str, '" = ", total) - -normalizeStatAndStringify t == - RNUMP t => - t := roundStat t - t = 0.0 => '"0" - FORMAT(nil,'"~,2F",t) - INTP t => - K := 1024 - M := K*K - t > 9*M => CONCAT(STRINGIMAGE((t + 512*K)/M), '"M") - t > 9*K => CONCAT(STRINGIMAGE((t + 512)/K), '"K") - STRINGIMAGE t - STRINGIMAGE t - -significantStat t == - RNUMP t => (t > 0.01) - INTP t => (t > 100) - true - -roundStat t == - not RNUMP t => t - (FIX (0.5 + t * 1000.0)) / 1000.0 - -makeStatString(oldstr,time,abb,flag) == - time = '"" => oldstr - opening := (flag = 'long => '"("; '" (") - oldstr = '"" => STRCONC(time,opening,abb,'")") - STRCONC(oldstr,'" + ",time,opening,abb,'")") - -peekTimedName() == IFCAR $timedNameStack - -popTimedName() == - name := IFCAR $timedNameStack - $timedNameStack := IFCDR $timedNameStack - name - -pushTimedName name == - PUSH(name,$timedNameStack) - ---currentlyTimedName() == CAR $timedNameStack - -startTimingProcess name == - updateTimedName peekTimedName() - pushTimedName name - if EQ(name, 'load) then statRecordLoadEvent() - -stopTimingProcess name == - (name ^= peekTimedName()) and null $InteractiveMode => - keyedSystemError("S2GL0015",[name,peekTimedName()]) - updateTimedName peekTimedName() - popTimedName() - ---% Instrumentation specific to the interpreter -SETANDFILEQ($oldElapsedSpace, 0) -SETANDFILEQ($oldElapsedGCTime,0.0) -SETANDFILEQ($oldElapsedTime,0.0) -SETANDFILEQ($gcTimeTotal,0.0) - --- $timedNameStack is used to hold the names of sections of the --- code being timed. - -SETANDFILEQ($timedNameStack,'(other)) - -SETANDFILEQ($interpreterTimedNames,'( --- name class abbrev - (algebra 2 . B) _ - (analysis 1 . A) _ - (coercion 1 . C) _ - (compilation 3 . T) _ - (debug 3 . D) _ - (evaluation 2 . E) _ - (gc 4 . G) _ - (history 3 . H) _ - (instantiation 3 . I) _ - (load 3 . L) _ - (modemaps 1 . M) _ - (optimization 3 . Z) _ - (querycoerce 1 . Q) _ - (other 3 . O) _ - (diskread 3 . K) _ - (print 3 . P) _ - (resolve 1 . R) _ - )) - -SETANDFILEQ($interpreterTimedClasses, '( --- number class name short name - ( 1 interpreter . IN) _ - ( 2 evaluation . EV) _ - ( 3 other . OT) _ - ( 4 reclaim . GC) _ - )) - -initializeTimedNames(listofnames,listofclasses) == - for [name,:.] in listofnames repeat - PUT(name, 'TimeTotal, 0.0) - PUT(name, 'SpaceTotal, 0) - for [.,name,:.] in listofclasses repeat - PUT( name, 'ClassTimeTotal, 0.0) - PUT( name, 'ClassSpaceTotal, 0) - $timedNameStack := '(other) - computeElapsedTime() - PUT('gc, 'TimeTotal, 0.0) - PUT('gc, 'SpaceTotal, 0) - NIL - -updateTimedName name == - count := (GETL(name,'TimeTotal) or 0) + computeElapsedTime() - PUT(name,'TimeTotal, count) - -printNamedStats listofnames == - printNamedStatsByProperty(listofnames, 'TimeTotal) - sayBrightly '" " - sayBrightly '"Space (in bytes):" - printNamedStatsByProperty(listofnames, 'SpaceTotal) - -makeLongTimeString(listofnames,listofclasses) == - makeLongStatStringByProperty(listofnames, listofclasses, _ - 'TimeTotal, 'ClassTimeTotal, _ - '"sec", $printTimeIfTrue) - -makeLongSpaceString(listofnames,listofclasses) == - makeLongStatStringByProperty(listofnames, listofclasses, _ - 'SpaceTotal, 'ClassSpaceTotal, _ - '"bytes", $printStorageIfTrue) - -computeElapsedTime() == - -- in total time lists, CAR is VIRTCPU and CADR is TOTCPU - currentTime:= elapsedUserTime() - currentGCTime:= elapsedGcTime() - gcDelta := currentGCTime - $oldElapsedGCTime - elapsedSeconds:= - -- In CCL total time does not include GC time. - $cclSystem => 1.*(currentTime-$oldElapsedTime)/$timerTicksPerSecond - 1.*(currentTime-$oldElapsedTime-gcDelta)/$timerTicksPerSecond - PUT('gc, 'TimeTotal,GETL('gc,'TimeTotal) + - 1.*gcDelta/$timerTicksPerSecond) - $oldElapsedTime := elapsedUserTime() - $oldElapsedGCTime := elapsedGcTime() - elapsedSeconds - -computeElapsedSpace() == - currentElapsedSpace := HEAPELAPSED() - elapsedBytes := currentElapsedSpace - $oldElapsedSpace - $oldElapsedSpace := currentElapsedSpace - elapsedBytes - -timedAlgebraEvaluation(code) == - startTimingProcess 'algebra - r := eval code - stopTimingProcess 'algebra - r - -timedOptimization(code) == - startTimingProcess 'optimization - $getDomainCode : local := NIL - r := lispize code - if $reportOptimization then - sayBrightlyI bright '"Optimized LISP code:" - pp r - stopTimingProcess 'optimization - r - -timedEVALFUN(code) == - startTimingProcess 'evaluation - r := timedEvaluate code - stopTimingProcess 'evaluation - r - -timedEvaluate code == - code is ["LIST",:a] and #a > 200 => - "append"/[eval ["LIST",:x] for x in splitIntoBlocksOf200 a] - eval code - -displayHeapStatsIfWanted() == - $printStorageIfTrue => sayBrightly OLDHEAPSTATS() - ---EVALANDFILEACTQ( --- PUTGCEXIT function displayHeapStatsIfWanted ) - ---% stubs for the stats summary fns -statRecordInstantiationEvent() == nil -statRecordLoadEvent() == nil - -statisticsSummary() == '"No statistics available." -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/g-util.boot b/src/interp/g-util.boot new file mode 100644 index 00000000..ea980250 --- /dev/null +++ b/src/interp/g-util.boot @@ -0,0 +1,638 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- 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. + + +import '"macros" +)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) + union(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" diff --git a/src/interp/g-util.boot.pamphlet b/src/interp/g-util.boot.pamphlet deleted file mode 100644 index 1b5b9f38..00000000 --- a/src/interp/g-util.boot.pamphlet +++ /dev/null @@ -1,664 +0,0 @@ -\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. - -@ -<<*>>= -<> - -import '"macros" -)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) - union(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} diff --git a/src/interp/hashcode.boot b/src/interp/hashcode.boot new file mode 100644 index 00000000..bcd1a554 --- /dev/null +++ b/src/interp/hashcode.boot @@ -0,0 +1,111 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- 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" + +-- Type hasher for old compiler style type names which produces a hash code +-- compatible with the asharp compiler. Takes a hard error if the type +-- is parameterized, but has no constructor modemap. +getDomainHash dom == SPADCALL(CDR dom, (CAR dom).4) + +hashType(type, percentHash) == + SYMBOLP type => + type = '$ => percentHash + type = "%" => percentHash + hashString SYMBOL_-NAME type + STRINGP type => hashCombine(hashString type, + hashString('"Enumeration")) + type is ['QUOTE, val] => hashType(val, percentHash) + type is [dom] => hashString SYMBOL_-NAME dom + type is ['_:, ., type2] => hashType(type2, percentHash) + isDomain type => getDomainHash type + [op, :args] := type + hash := hashString SYMBOL_-NAME op + op = 'Mapping => + hash := hashString '"->" + [retType, :mapArgs] := args + for arg in mapArgs repeat + hash := hashCombine(hashType(arg, percentHash), hash) + retCode := hashType(retType, percentHash) + EQL(retCode, $VoidHash) => hash + hashCombine(retCode, hash) + op = 'Enumeration => + for arg in args repeat + hash := hashCombine(hashString(STRING arg), hash) + hash + op in $DomainsWithoutLisplibs => + for arg in args repeat + hash := hashCombine(hashType(arg, percentHash), hash) + hash + + cmm := CDDAR getConstructorModemap(op) + cosig := CDR GETDATABASE(op, 'COSIG) + for arg in args for c in cosig for ct in cmm repeat + if c then + hash := hashCombine(hashType(arg, percentHash), hash) + else + hash := hashCombine(7, hash) +-- !!! If/when asharp hashes values using their type, use instead +-- ctt := EQSUBSTLIST(args, $FormalMapVariableList, ct) +-- hash := hashCombine(hashType(ctt, percentHash), hash) + + + hash + +--The following are in cfuns.lisp +$hashModulus := 1073741789 -- largest 30-bit prime + +-- Produce a 30-bit hash code. This function must produce the same codes +-- as the asharp string hasher in src/strops.c +hashString str == + h := 0 + for i in 0..#str-1 repeat + j := CHAR_-CODE char str.i + h := LOGXOR(h, ASH(h, 8)) + h := h + j + 200041 + h := LOGAND(h, 1073741823) -- 0x3FFFFFFF + REM(h, $hashModulus) + +-- Combine two hash codes to make a new one. Must be the same as in +-- the hashCombine function in aslib/runtime.as in asharp. +hashCombine(hash1, hash2) == + MOD(ASH(LOGAND(hash2, 16777215), 6) + hash1, $hashModulus) + + +$VoidHash := hashString '"Void" + + +-- following two lines correct bad coSig properties due to SubsetCategory +--putConstructorProperty('LocalAlgebra,'coSig,'(NIL T T T)) +--putConstructorProperty('Localize,'coSig,'(NIL T T T)) diff --git a/src/interp/hashcode.boot.pamphlet b/src/interp/hashcode.boot.pamphlet deleted file mode 100644 index 4a0f640e..00000000 --- a/src/interp/hashcode.boot.pamphlet +++ /dev/null @@ -1,131 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp hashcode.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\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" - --- Type hasher for old compiler style type names which produces a hash code --- compatible with the asharp compiler. Takes a hard error if the type --- is parameterized, but has no constructor modemap. -getDomainHash dom == SPADCALL(CDR dom, (CAR dom).4) - -hashType(type, percentHash) == - SYMBOLP type => - type = '$ => percentHash - type = "%" => percentHash - hashString SYMBOL_-NAME type - STRINGP type => hashCombine(hashString type, - hashString('"Enumeration")) - type is ['QUOTE, val] => hashType(val, percentHash) - type is [dom] => hashString SYMBOL_-NAME dom - type is ['_:, ., type2] => hashType(type2, percentHash) - isDomain type => getDomainHash type - [op, :args] := type - hash := hashString SYMBOL_-NAME op - op = 'Mapping => - hash := hashString '"->" - [retType, :mapArgs] := args - for arg in mapArgs repeat - hash := hashCombine(hashType(arg, percentHash), hash) - retCode := hashType(retType, percentHash) - EQL(retCode, $VoidHash) => hash - hashCombine(retCode, hash) - op = 'Enumeration => - for arg in args repeat - hash := hashCombine(hashString(STRING arg), hash) - hash - op in $DomainsWithoutLisplibs => - for arg in args repeat - hash := hashCombine(hashType(arg, percentHash), hash) - hash - - cmm := CDDAR getConstructorModemap(op) - cosig := CDR GETDATABASE(op, 'COSIG) - for arg in args for c in cosig for ct in cmm repeat - if c then - hash := hashCombine(hashType(arg, percentHash), hash) - else - hash := hashCombine(7, hash) --- !!! If/when asharp hashes values using their type, use instead --- ctt := EQSUBSTLIST(args, $FormalMapVariableList, ct) --- hash := hashCombine(hashType(ctt, percentHash), hash) - - - hash - ---The following are in cfuns.lisp -$hashModulus := 1073741789 -- largest 30-bit prime - --- Produce a 30-bit hash code. This function must produce the same codes --- as the asharp string hasher in src/strops.c -hashString str == - h := 0 - for i in 0..#str-1 repeat - j := CHAR_-CODE char str.i - h := LOGXOR(h, ASH(h, 8)) - h := h + j + 200041 - h := LOGAND(h, 1073741823) -- 0x3FFFFFFF - REM(h, $hashModulus) - --- Combine two hash codes to make a new one. Must be the same as in --- the hashCombine function in aslib/runtime.as in asharp. -hashCombine(hash1, hash2) == - MOD(ASH(LOGAND(hash2, 16777215), 6) + hash1, $hashModulus) - - -$VoidHash := hashString '"Void" - - --- following two lines correct bad coSig properties due to SubsetCategory ---putConstructorProperty('LocalAlgebra,'coSig,'(NIL T T T)) ---putConstructorProperty('Localize,'coSig,'(NIL T T T)) -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/ht-root.boot b/src/interp/ht-root.boot new file mode 100644 index 00000000..b81501a1 --- /dev/null +++ b/src/interp/ht-root.boot @@ -0,0 +1,295 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- 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. + + +import '"ht-util" +)package "BOOT" + +$historyDisplayWidth := 120 +$newline := char 10 + +downlink page == + $saturn => downlinkSaturn page + htInitPage('"Bridge",nil) + htSay('"\replacepage{", page, '"}") + htShowPage() + +downlinkSaturn fn == + u := dbReadLines(fn) + lines := '"" + while u is [line,:u] repeat + n := MAXINDEX line + n < 1 => nil + line.0 = (char '_%) => nil + lines := STRCONC(lines,line) + issueHTSaturn lines + +dbNonEmptyPattern pattern == + null pattern => '"*" + pattern := STRINGIMAGE pattern + #pattern > 0 => pattern + '"*" + +htSystemVariables() == main where + main() == + not $fullScreenSysVars => htSetVars() + classlevel := $UserLevel + $levels : local := '(compiler development interpreter) + $heading : local := nil + while classlevel ^= first $levels repeat $levels := rest $levels + table := NREVERSE fn($setOptions,nil,true) + htInitPage('"System Variables",nil) + htSay '"\beginmenu" + lastHeading := nil + for [heading,name,message,.,key,variable,options,func] in table repeat + htSay('"\newline\item ") + if heading = lastHeading then htSay '"\tab{8}" else + htSay(heading,'"\tab{8}") + lastHeading := heading + htSay('"{\em ",name,"}\tab{22}",message) + htSay('"\tab{80}") + key = 'FUNCTION => + null options => htMakePage [['bcLinks,['"reset",'"",func,nil]]] + [msg,class,var,valuesOrFunction,:.] := first options --skip first message + functionTail(name,class,var,valuesOrFunction) + for option in rest options repeat + option is ['break,:.] => 'skip + [msg,class,var,valuesOrFunction,:.] := option + htSay('"\newline\tab{22}", msg,'"\tab{80}") + functionTail(name,class,var,valuesOrFunction) + val := eval variable + displayOptions(name,key,variable,val,options) + htSay '"\endmenu" + htShowPage() + where + functionTail(name,class,var,valuesOrFunction) == + val := eval var + atom valuesOrFunction => + htMakePage '((domainConditions (isDomain STR (String)))) + htMakePage [['bcLinks,['"reset",'"",'htSetSystemVariableKind,[var,name,nil]]]] + htMakePage [['bcStrings,[30,STRINGIMAGE val,name,valuesOrFunction]]] + displayOptions(name,class,var,val,valuesOrFunction) + displayOptions(name,class,variable,val,options) == + class = 'INTEGER => + htMakePage [['bcLispLinks,[[['text,options.0,'"-",options.1 or '""]],'"",'htSetSystemVariableKind,[variable,name,'PARSE_-INTEGER]]]] + htMakePage '((domainConditions (isDomain INT (Integer)))) + htMakePage [['bcStrings,[5,STRINGIMAGE val,name,'INT]]] + class = 'STRING => + htSay('"{\em ",val,'"}\space{1}") + for x in options repeat + val = x or val = true and x = 'on or null val and x = 'off => + htSay('"{\em ",x,'"}\space{1}") + htMakePage [['bcLispLinks,[x,'" ",'htSetSystemVariable,[variable,x]]]] + fn(t,al,firstTime) == + atom t => al + if firstTime then $heading := opOf first t + fn(rest t,gn(first t,al),firstTime) + gn(t,al) == + [.,.,class,key,.,options,:.] := t + not MEMQ(class,$levels) => al + key = 'LITERALS or key = 'INTEGER or key = 'STRING => [[$heading,:t],:al] + key = 'TREE => fn(options,al,false) + key = 'FUNCTION => [[$heading,:t],:al] + systemError key + +htSetSystemVariableKind(htPage,[variable,name,fun]) == + value := htpLabelInputString(htPage,name) + if STRINGP value and fun then value := FUNCALL(fun,value) +--SCM::what to do??? if not FIXP value then userError ??? + SET(variable,value) + htSystemVariables () + +htSetSystemVariable(htPage,[name,value]) == + value := + value = 'on => true + value = 'off => nil + value + SET(name,value) + htSystemVariables () + +htGloss(pattern) == htGlossPage(nil,dbNonEmptyPattern pattern or '"*",true) + +htGlossPage(htPage,pattern,tryAgain?) == + $wildCard: local := char '_* + pattern = '"*" => downlink 'GlossaryPage + filter := pmTransFilter pattern + grepForm := mkGrepPattern(filter,'none) + $key: local := 'none + results := applyGrep(grepForm,'gloss) + --pathname := STRCONC('"/tmp/",PNAME resultFile,'".text.", getEnv '"SPADNUM") + --instream := MAKE_-INSTREAM pathname + defstream := MAKE_-INSTREAM STRCONC(systemRootDirectory(),'"/algebra/glossdef.text") + lines := gatherGlossLines(results,defstream) + -- OBEY STRCONC('"rm -f ", pathname) + --PROBE_-FILE(pathname) and DELETE_-FILE(pathname) + --SHUT instream + heading := + pattern = '"" => '"Glossary" + null lines => ['"No glossary items match {\em ",pattern,'"}"] + ['"Glossary items matching {\em ",pattern,'"}"] + null lines => + tryAgain? and #pattern > 0 => + (pattern.(k := MAXINDEX(pattern))) = char 's => + htGlossPage(htPage,SUBSTRING(pattern,0,k),true) + UPPER_-CASE_-P pattern.0 => + htGlossPage(htPage,DOWNCASE pattern,false) + errorPage(htPage,['"Sorry",nil,['"\centerline{",:heading,'"}"]]) + errorPage(htPage,['"Sorry",nil,['"\centerline{",:heading,'"}"]]) + htInitPageNoScroll(nil,heading) + htSay('"\beginscroll\beginmenu") + for line in lines repeat + tick := charPosition($tick,line,1) + htSay('"\item{\em \menuitemstyle{}}\tab{0}{\em ",escapeString SUBSTRING(line,0,tick),'"} ",SUBSTRING(line,tick + 1,nil)) + htSay '"\endmenu " + htSay '"\endscroll\newline " + htMakePage [['bcLinks,['"Search",'"",'htGlossSearch,nil]]] + htSay '" for glossary entry matching " + htMakePage [['bcStrings, [24,'"*",'filter,'EM]]] + htShowPageNoScroll() + +gatherGlossLines(results,defstream) == + acc := nil + for keyline in results repeat + --keyline := READLINE instream + n := charPosition($tick,keyline,0) + keyAndTick := SUBSTRING(keyline,0,n + 1) + byteAddress := string2Integer SUBSTRING(keyline,n + 1,nil) + FILE_-POSITION(defstream,byteAddress) + line := READLINE defstream + k := charPosition($tick,line,1) + pointer := SUBSTRING(line,0,k) + def := SUBSTRING(line,k + 1,nil) + xtralines := nil + while not EOFP defstream and (x := READLINE defstream) and + (j := charPosition($tick,x,1)) and (nextPointer := SUBSTRING(x,0,j)) + and (nextPointer = pointer) repeat + xtralines := [SUBSTRING(x,j + 1,nil),:xtralines] + acc := [STRCONC(keyAndTick,def, "STRCONC"/NREVERSE xtralines),:acc] + REVERSE acc + +htGlossSearch(htPage,junk) == htGloss htpLabelInputString(htPage,'filter) + +htGreekSearch(filter) == + ss := dbNonEmptyPattern filter + s := pmTransFilter ss + s is ['error,:.] => bcErrorPage s + not s => errorPage(nil,[['"Missing search string"],nil, + '"\vspace{2}\centerline{To select one of the greek letters:}\newline ", + '"\centerline{{\em first} enter a search key into the input area}\newline ", + '"\centerline{{\em then } move the mouse cursor to the work {\em search} and click}"]) + filter := patternCheck s + names := '(alpha beta gamma delta epsilon zeta eta theta iota kappa lambda mu nu pi) + for x in names repeat + superMatch?(filter,PNAME x) => matches := [x,:matches] + nonmatches := [x,:nonmatches] + matches := NREVERSE matches + nonmatches := NREVERSE nonmatches + htInitPage('"Greek Names",nil) + null matches => + htInitPage(['"Greek names matching search string {\em ",ss,'"}"],nil) + htSay("\vspace{2}\centerline{Sorry, but no greek letters match your search string}\centerline{{\em ",ss,"}}\centerline{Click on the up-arrow to try again}") + htShowPage() + htInitPage(['"Greek letters matching search string {\em ",ss,'"}"],nil) + if nonmatches + then htSay('"The greek letters that {\em match} your search string {\em ",ss,'"}:") + else htSay('"Your search string {\em ",ss,"} matches all of the greek letters:") + htSay('"{\em \table{") + for x in matches repeat htSay('"{",x,'"}") + htSay('"}}\vspace{1}") + if nonmatches then + htSay('"The greek letters that {\em do not match} your search string:{\em \table{") + for x in nonmatches repeat htSay('"{",x,'"}") + htSay('"}}") + htShowPage() + +htTextSearch(filter) == + s := pmTransFilter dbNonEmptyPattern filter + s is ['error,:.] => bcErrorPage s + not s => errorPage(nil,[['"Missing search string"],nil, + '"\vspace{2}\centerline{To select one of the lines of text:}\newline ", + '"\centerline{{\em first} enter a search key into the input area}\newline ", + '"\centerline{{\em then } move the mouse cursor to the work {\em search} and click}"]) + filter := s + lines := ['"{{\em Fruit flies} *like* a {\em banana and califlower ears.}}", + '"{{\em Sneak Sears Silas with Savings Snatch}}"] + for x in lines repeat + superMatch?(filter,x) => matches := [x,:matches] + nonmatches := [x,:nonmatches] + matches := NREVERSE matches + nonmatches := NREVERSE nonmatches + htInitPage('"Text Matches",nil) + null matches => + htInitPage(['"Lines matching search string {\em ",s,'"}"],nil) + htSay("\vspace{2}\centerline{Sorry, but no lines match your search string}\centerline{{\em ",s,"}}\centerline{Click on the up-arrow to try again}") + htShowPage() + htInitPage(['"Lines matching search string {\em ",s,'"}"],nil) + if nonmatches + then htSay('"The lines that {\em match} your search string {\em ",s,'"}:") + else htSay('"Your search string {\em ",s,"} matches both lines:") + htSay('"{\em \table{") + for x in matches repeat htSay('"{",x,'"}") + htSay('"}}\vspace{1}") + if nonmatches then + htSay('"The line that {\em does not match} your search string:{\em \table{") + for x in nonmatches repeat htSay('"{",x,'"}") + htSay('"}}") + htShowPage() + +htTutorialSearch pattern == + s := dbNonEmptyPattern pattern or return + errorPage(nil,['"Empty search key",nil,'"\vspace{3}\centerline{You must enter some search string"]) + s := mkUnixPattern s + source := '"$AXIOM/share/hypertex/pages/ht.db" + target :='"/tmp/temp.text.$SPADNUM" + OBEY STRCONC('"$AXIOM/lib/hthits",'" _"",s,'"_" ",source,'" > ",target) + lines := dbReadLines 'temp + htInitPageNoScroll(nil,['"Tutorial Pages mentioning {\em ",pattern,'"}"]) + htSay('"\beginscroll\table{") + for line in lines repeat + [name,title,.] := dbParts(line,3,0) + htSay ['"{\downlink{",title,'"}{",name,'"}}"] + htSay '"}" + htShowPage() + +mkUnixPattern s == + u := mkUpDownPattern s + starPositions := REVERSE [i for i in 1..(-1 + MAXINDEX u) | u.i = $wild] + for i in starPositions repeat + u := STRCONC(SUBSTRING(u,0,i),'".*",SUBSTRING(u,i + 1,nil)) + if u.0 ^= $wild then u := STRCONC('"[^a-zA-Z]",u) + else u := SUBSTRING(u,1,nil) + if u.(k := MAXINDEX u) ^= $wild then u := STRCONC(u,'"[^a-zA-Z]") + else u := SUBSTRING(u,0,k) + u + + diff --git a/src/interp/ht-root.boot.pamphlet b/src/interp/ht-root.boot.pamphlet deleted file mode 100644 index 9ec1bbf3..00000000 --- a/src/interp/ht-root.boot.pamphlet +++ /dev/null @@ -1,315 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp ht-root.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\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. - -@ -<<*>>= -<> - -import '"ht-util" -)package "BOOT" - -$historyDisplayWidth := 120 -$newline := char 10 - -downlink page == - $saturn => downlinkSaturn page - htInitPage('"Bridge",nil) - htSay('"\replacepage{", page, '"}") - htShowPage() - -downlinkSaturn fn == - u := dbReadLines(fn) - lines := '"" - while u is [line,:u] repeat - n := MAXINDEX line - n < 1 => nil - line.0 = (char '_%) => nil - lines := STRCONC(lines,line) - issueHTSaturn lines - -dbNonEmptyPattern pattern == - null pattern => '"*" - pattern := STRINGIMAGE pattern - #pattern > 0 => pattern - '"*" - -htSystemVariables() == main where - main() == - not $fullScreenSysVars => htSetVars() - classlevel := $UserLevel - $levels : local := '(compiler development interpreter) - $heading : local := nil - while classlevel ^= first $levels repeat $levels := rest $levels - table := NREVERSE fn($setOptions,nil,true) - htInitPage('"System Variables",nil) - htSay '"\beginmenu" - lastHeading := nil - for [heading,name,message,.,key,variable,options,func] in table repeat - htSay('"\newline\item ") - if heading = lastHeading then htSay '"\tab{8}" else - htSay(heading,'"\tab{8}") - lastHeading := heading - htSay('"{\em ",name,"}\tab{22}",message) - htSay('"\tab{80}") - key = 'FUNCTION => - null options => htMakePage [['bcLinks,['"reset",'"",func,nil]]] - [msg,class,var,valuesOrFunction,:.] := first options --skip first message - functionTail(name,class,var,valuesOrFunction) - for option in rest options repeat - option is ['break,:.] => 'skip - [msg,class,var,valuesOrFunction,:.] := option - htSay('"\newline\tab{22}", msg,'"\tab{80}") - functionTail(name,class,var,valuesOrFunction) - val := eval variable - displayOptions(name,key,variable,val,options) - htSay '"\endmenu" - htShowPage() - where - functionTail(name,class,var,valuesOrFunction) == - val := eval var - atom valuesOrFunction => - htMakePage '((domainConditions (isDomain STR (String)))) - htMakePage [['bcLinks,['"reset",'"",'htSetSystemVariableKind,[var,name,nil]]]] - htMakePage [['bcStrings,[30,STRINGIMAGE val,name,valuesOrFunction]]] - displayOptions(name,class,var,val,valuesOrFunction) - displayOptions(name,class,variable,val,options) == - class = 'INTEGER => - htMakePage [['bcLispLinks,[[['text,options.0,'"-",options.1 or '""]],'"",'htSetSystemVariableKind,[variable,name,'PARSE_-INTEGER]]]] - htMakePage '((domainConditions (isDomain INT (Integer)))) - htMakePage [['bcStrings,[5,STRINGIMAGE val,name,'INT]]] - class = 'STRING => - htSay('"{\em ",val,'"}\space{1}") - for x in options repeat - val = x or val = true and x = 'on or null val and x = 'off => - htSay('"{\em ",x,'"}\space{1}") - htMakePage [['bcLispLinks,[x,'" ",'htSetSystemVariable,[variable,x]]]] - fn(t,al,firstTime) == - atom t => al - if firstTime then $heading := opOf first t - fn(rest t,gn(first t,al),firstTime) - gn(t,al) == - [.,.,class,key,.,options,:.] := t - not MEMQ(class,$levels) => al - key = 'LITERALS or key = 'INTEGER or key = 'STRING => [[$heading,:t],:al] - key = 'TREE => fn(options,al,false) - key = 'FUNCTION => [[$heading,:t],:al] - systemError key - -htSetSystemVariableKind(htPage,[variable,name,fun]) == - value := htpLabelInputString(htPage,name) - if STRINGP value and fun then value := FUNCALL(fun,value) ---SCM::what to do??? if not FIXP value then userError ??? - SET(variable,value) - htSystemVariables () - -htSetSystemVariable(htPage,[name,value]) == - value := - value = 'on => true - value = 'off => nil - value - SET(name,value) - htSystemVariables () - -htGloss(pattern) == htGlossPage(nil,dbNonEmptyPattern pattern or '"*",true) - -htGlossPage(htPage,pattern,tryAgain?) == - $wildCard: local := char '_* - pattern = '"*" => downlink 'GlossaryPage - filter := pmTransFilter pattern - grepForm := mkGrepPattern(filter,'none) - $key: local := 'none - results := applyGrep(grepForm,'gloss) - --pathname := STRCONC('"/tmp/",PNAME resultFile,'".text.", getEnv '"SPADNUM") - --instream := MAKE_-INSTREAM pathname - defstream := MAKE_-INSTREAM STRCONC(systemRootDirectory(),'"/algebra/glossdef.text") - lines := gatherGlossLines(results,defstream) - -- OBEY STRCONC('"rm -f ", pathname) - --PROBE_-FILE(pathname) and DELETE_-FILE(pathname) - --SHUT instream - heading := - pattern = '"" => '"Glossary" - null lines => ['"No glossary items match {\em ",pattern,'"}"] - ['"Glossary items matching {\em ",pattern,'"}"] - null lines => - tryAgain? and #pattern > 0 => - (pattern.(k := MAXINDEX(pattern))) = char 's => - htGlossPage(htPage,SUBSTRING(pattern,0,k),true) - UPPER_-CASE_-P pattern.0 => - htGlossPage(htPage,DOWNCASE pattern,false) - errorPage(htPage,['"Sorry",nil,['"\centerline{",:heading,'"}"]]) - errorPage(htPage,['"Sorry",nil,['"\centerline{",:heading,'"}"]]) - htInitPageNoScroll(nil,heading) - htSay('"\beginscroll\beginmenu") - for line in lines repeat - tick := charPosition($tick,line,1) - htSay('"\item{\em \menuitemstyle{}}\tab{0}{\em ",escapeString SUBSTRING(line,0,tick),'"} ",SUBSTRING(line,tick + 1,nil)) - htSay '"\endmenu " - htSay '"\endscroll\newline " - htMakePage [['bcLinks,['"Search",'"",'htGlossSearch,nil]]] - htSay '" for glossary entry matching " - htMakePage [['bcStrings, [24,'"*",'filter,'EM]]] - htShowPageNoScroll() - -gatherGlossLines(results,defstream) == - acc := nil - for keyline in results repeat - --keyline := READLINE instream - n := charPosition($tick,keyline,0) - keyAndTick := SUBSTRING(keyline,0,n + 1) - byteAddress := string2Integer SUBSTRING(keyline,n + 1,nil) - FILE_-POSITION(defstream,byteAddress) - line := READLINE defstream - k := charPosition($tick,line,1) - pointer := SUBSTRING(line,0,k) - def := SUBSTRING(line,k + 1,nil) - xtralines := nil - while not EOFP defstream and (x := READLINE defstream) and - (j := charPosition($tick,x,1)) and (nextPointer := SUBSTRING(x,0,j)) - and (nextPointer = pointer) repeat - xtralines := [SUBSTRING(x,j + 1,nil),:xtralines] - acc := [STRCONC(keyAndTick,def, "STRCONC"/NREVERSE xtralines),:acc] - REVERSE acc - -htGlossSearch(htPage,junk) == htGloss htpLabelInputString(htPage,'filter) - -htGreekSearch(filter) == - ss := dbNonEmptyPattern filter - s := pmTransFilter ss - s is ['error,:.] => bcErrorPage s - not s => errorPage(nil,[['"Missing search string"],nil, - '"\vspace{2}\centerline{To select one of the greek letters:}\newline ", - '"\centerline{{\em first} enter a search key into the input area}\newline ", - '"\centerline{{\em then } move the mouse cursor to the work {\em search} and click}"]) - filter := patternCheck s - names := '(alpha beta gamma delta epsilon zeta eta theta iota kappa lambda mu nu pi) - for x in names repeat - superMatch?(filter,PNAME x) => matches := [x,:matches] - nonmatches := [x,:nonmatches] - matches := NREVERSE matches - nonmatches := NREVERSE nonmatches - htInitPage('"Greek Names",nil) - null matches => - htInitPage(['"Greek names matching search string {\em ",ss,'"}"],nil) - htSay("\vspace{2}\centerline{Sorry, but no greek letters match your search string}\centerline{{\em ",ss,"}}\centerline{Click on the up-arrow to try again}") - htShowPage() - htInitPage(['"Greek letters matching search string {\em ",ss,'"}"],nil) - if nonmatches - then htSay('"The greek letters that {\em match} your search string {\em ",ss,'"}:") - else htSay('"Your search string {\em ",ss,"} matches all of the greek letters:") - htSay('"{\em \table{") - for x in matches repeat htSay('"{",x,'"}") - htSay('"}}\vspace{1}") - if nonmatches then - htSay('"The greek letters that {\em do not match} your search string:{\em \table{") - for x in nonmatches repeat htSay('"{",x,'"}") - htSay('"}}") - htShowPage() - -htTextSearch(filter) == - s := pmTransFilter dbNonEmptyPattern filter - s is ['error,:.] => bcErrorPage s - not s => errorPage(nil,[['"Missing search string"],nil, - '"\vspace{2}\centerline{To select one of the lines of text:}\newline ", - '"\centerline{{\em first} enter a search key into the input area}\newline ", - '"\centerline{{\em then } move the mouse cursor to the work {\em search} and click}"]) - filter := s - lines := ['"{{\em Fruit flies} *like* a {\em banana and califlower ears.}}", - '"{{\em Sneak Sears Silas with Savings Snatch}}"] - for x in lines repeat - superMatch?(filter,x) => matches := [x,:matches] - nonmatches := [x,:nonmatches] - matches := NREVERSE matches - nonmatches := NREVERSE nonmatches - htInitPage('"Text Matches",nil) - null matches => - htInitPage(['"Lines matching search string {\em ",s,'"}"],nil) - htSay("\vspace{2}\centerline{Sorry, but no lines match your search string}\centerline{{\em ",s,"}}\centerline{Click on the up-arrow to try again}") - htShowPage() - htInitPage(['"Lines matching search string {\em ",s,'"}"],nil) - if nonmatches - then htSay('"The lines that {\em match} your search string {\em ",s,'"}:") - else htSay('"Your search string {\em ",s,"} matches both lines:") - htSay('"{\em \table{") - for x in matches repeat htSay('"{",x,'"}") - htSay('"}}\vspace{1}") - if nonmatches then - htSay('"The line that {\em does not match} your search string:{\em \table{") - for x in nonmatches repeat htSay('"{",x,'"}") - htSay('"}}") - htShowPage() - -htTutorialSearch pattern == - s := dbNonEmptyPattern pattern or return - errorPage(nil,['"Empty search key",nil,'"\vspace{3}\centerline{You must enter some search string"]) - s := mkUnixPattern s - source := '"$AXIOM/share/hypertex/pages/ht.db" - target :='"/tmp/temp.text.$SPADNUM" - OBEY STRCONC('"$AXIOM/lib/hthits",'" _"",s,'"_" ",source,'" > ",target) - lines := dbReadLines 'temp - htInitPageNoScroll(nil,['"Tutorial Pages mentioning {\em ",pattern,'"}"]) - htSay('"\beginscroll\table{") - for line in lines repeat - [name,title,.] := dbParts(line,3,0) - htSay ['"{\downlink{",title,'"}{",name,'"}}"] - htSay '"}" - htShowPage() - -mkUnixPattern s == - u := mkUpDownPattern s - starPositions := REVERSE [i for i in 1..(-1 + MAXINDEX u) | u.i = $wild] - for i in starPositions repeat - u := STRCONC(SUBSTRING(u,0,i),'".*",SUBSTRING(u,i + 1,nil)) - if u.0 ^= $wild then u := STRCONC('"[^a-zA-Z]",u) - else u := SUBSTRING(u,1,nil) - if u.(k := MAXINDEX u) ^= $wild then u := STRCONC(u,'"[^a-zA-Z]") - else u := SUBSTRING(u,0,k) - u - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/ht-util.boot b/src/interp/ht-util.boot new file mode 100644 index 00000000..36330ed6 --- /dev/null +++ b/src/interp/ht-util.boot @@ -0,0 +1,735 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- 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. + + +import '"macros" +)package "BOOT" + +-- HyperTeX Utilities for generating basic Command pages + +$bcParseOnly := true + +-- List of issued hypertex lines +$htLineList := nil + +-- pointer to the page we are currently defining +$curPage := nil + +-- List of currently active window named +$activePageList := nil + +htpDestroyPage(pageName) == + pageName in $activePageList => + SET(pageName, nil) + $activePageList := NREMOVE($activePageList, pageName) + +htpName htPage == +-- GENSYM whose value is the page + ELT(htPage, 0) + +htpSetName(htPage, val) == + SETELT(htPage, 0, val) + +htpDomainConditions htPage == +-- List of Domain conditions + ELT(htPage, 1) + +htpSetDomainConditions(htPage, val) == + SETELT(htPage, 1, val) + +htpDomainVariableAlist htPage == +-- alist of pattern variables and conditions + ELT(htPage, 2) + +htpSetDomainVariableAlist(htPage, val) == + SETELT(htPage, 2, val) + +htpDomainPvarSubstList htPage == +-- alist of user pattern variables to system vars + ELT(htPage, 3) + +htpSetDomainPvarSubstList(htPage, val) == + SETELT(htPage, 3, val) + +htpRadioButtonAlist htPage == +-- alist of radio button group names and labels + ELT(htPage, 4) + +htpButtonValue(htPage, groupName) == + for buttonName in LASSOC(groupName, htpRadioButtonAlist htPage) repeat + (stripSpaces htpLabelInputString(htPage, buttonName)) = '"t" => + return buttonName + +htpSetRadioButtonAlist(htPage, val) == + SETELT(htPage, 4, val) + +htpInputAreaAlist htPage == +-- Alist of input-area labels, and default values + ELT(htPage, 5) + +htpSetInputAreaAlist(htPage, val) == + SETELT(htPage, 5, val) + +htpAddInputAreaProp(htPage, label, prop) == + SETELT(htPage, 5, [[label, nil, nil, nil, :prop], :ELT(htPage, 5)]) + +htpPropertyList htPage == +-- Association list of user-defined properties + ELT(htPage, 6) + +htpProperty(htPage, propName) == + LASSOC(propName, ELT(htPage, 6)) + +htpSetProperty(htPage, propName, val) == + pair := assoc(propName, ELT(htPage, 6)) + pair => RPLACD(pair, val) + SETELT(htPage, 6, [[propName, :val], :ELT(htPage, 6)]) + +htpLabelInputString(htPage, label) == +-- value user typed as input string on page + props := LASSOC(label, htpInputAreaAlist htPage) + props and STRINGP (s := ELT(props,0)) => + s = '"" => s + trimString s + nil + +htpLabelFilteredInputString(htPage, label) == +-- value user typed as input string on page + props := LASSOC(label, htpInputAreaAlist htPage) + props => + #props > 5 and ELT(props, 6) => + FUNCALL(SYMBOL_-FUNCTION ELT(props, 6), ELT(props, 0)) + replacePercentByDollar ELT(props, 0) + nil + +replacePercentByDollar s == fn(s,0,MAXINDEX s) where + fn(s,i,n) == + i > n => '"" + (m := charPosition(char "%",s,i)) > n => SUBSTRING(s,i,nil) + STRCONC(SUBSTRING(s,i,m - i),'"$",fn(s,m + 1,n)) + +htpSetLabelInputString(htPage, label, val) == +------------------> OBSELETE +-- value user typed as input string on page + props := LASSOC(label, htpInputAreaAlist htPage) + props => SETELT(props, 0, STRINGIMAGE val) + nil + +htpLabelSpadValue(htPage, label) == +-- Scratchpad value of parsed and evaled inputString, as (type . value) + props := LASSOC(label, htpInputAreaAlist htPage) + props => ELT(props, 1) + nil + +htpSetLabelSpadValue(htPage, label, val) == +-- value user typed as input string on page + props := LASSOC(label, htpInputAreaAlist htPage) + props => SETELT(props, 1, val) + nil + +htpLabelErrorMsg(htPage, label) == +-- error message associated with input area + props := LASSOC(label, htpInputAreaAlist htPage) + props => ELT(props, 2) + nil + +htpSetLabelErrorMsg(htPage, label, val) == +-- error message associated with input area + props := LASSOC(label, htpInputAreaAlist htPage) + props => SETELT(props, 2, val) + nil + +htpLabelType(htPage, label) == +-- either 'string or 'button + props := LASSOC(label, htpInputAreaAlist htPage) + props => ELT(props, 3) + nil + +htpLabelDefault(htPage, label) == +-- default value for the input area + msg := htpLabelInputString(htPage, label) => + msg = '"t" => 1 + msg = '"nil" => 0 + msg + props := LASSOC(label, htpInputAreaAlist htPage) + props => + ELT(props, 4) + nil + + +htpLabelSpadType(htPage, label) == +-- pattern variable for target domain for input area + props := LASSOC(label, htpInputAreaAlist htPage) + props => ELT(props, 5) + nil + +htpLabelFilter(htPage, label) == +-- string to string mapping applied to input area strings before parsing + props := LASSOC(label, htpInputAreaAlist htPage) + props => ELT(props, 6) + nil + +htpPageDescription htPage == +-- a list of all the commands issued to create the basic-command page + ELT(htPage, 7) + +htpSetPageDescription(htPage, pageDescription) == + SETELT(htPage, 7, pageDescription) + +htpAddToPageDescription(htPage, pageDescrip) == +-------------> OBSELETE <----------- + SETELT(htPage, 7, nconc(nreverse COPY_-LIST pageDescrip, ELT(htPage, 7))) + +iht line == +-- issue a single hyperteTeX line, or a group of lines + $newPage => nil + PAIRP line => + $htLineList := NCONC(nreverse mapStringize COPY_-LIST line, $htLineList) + $htLineList := [basicStringize line, :$htLineList] + +bcHt line == +--line = '"\##1" => harharhar() + iht line + PAIRP line => + if $newPage then htpAddToPageDescription($curPage, [['text, :line]]) + if $newPage then htpAddToPageDescription($curPage, [['text, line]]) + +bcIssueHt line == + PAIRP line => htMakePage1 line + iht line + +mapStringize l == + ATOM l => l + RPLACA(l, basicStringize CAR l) + RPLACD(l, mapStringize CDR l) + l + +basicStringize s == + STRINGP s => + s = '"\$" => '"\%" + s = '"{\em $}" => '"{\em \%}" + s + s = '_$ => '"\%" + PRINC_-TO_-STRING s + +stringize s == + STRINGP s => s + PRINC_-TO_-STRING s + +htInitPage(title, propList) == +----------------------------> OBSELETE---cannot return $curPage +-- start defining a hyperTeX page + htInitPageNoScroll(propList, title) + htSayStandard '"\beginscroll " + $curPage + + +--htInitPageNoHeading(propList) == +-----------------------> replaced by htInitPageNoScroll +-- start defining a hyperTeX page +-- $curPage := htpMakeEmptyPage(propList) +-- if $saturn then $saturnPage := htpMakeEmptyPage(propList) +-- $newPage := true +-- $htLineList := nil +-- $curPage + +htAddHeading(title) == +------------------------> OBSELETE + htNewPage title + $curPage + +htShowPage() == +-- show the page which has been computed + htSayStandard '"\endscroll" + htShowPageNoScroll() + +htShowPageNoScroll() == +------------------------> OBSELETE +-- show the page which has been computed + htSayStandard '"\autobuttons" + htpSetPageDescription($curPage, nreverse htpPageDescription $curPage) + $newPage := false + $htLineList := nil + htMakePage htpPageDescription $curPage + line := APPLY(function CONCAT, nreverse $htLineList) + issueHT line + endHTPage() + +htMakePage itemList == +------------------------> OBSELETE +-- make a page given the description in itemList + if $newPage then htpAddToPageDescription($curPage, itemList) + htMakePage1 itemList + +htMakePage1 itemList == +-- make a page given the description in itemList + for [itemType, :items] in itemList repeat + itemType = 'text => iht items + itemType = 'lispLinks => htLispLinks items + itemType = 'lispmemoLinks => htLispMemoLinks items + itemType = 'bcLinks => htBcLinks items ---> + itemType = 'bcLinksNS => htBcLinks(items,true) + itemType = 'bcLispLinks => htBcLispLinks items ---> + itemType = 'radioButtons => htRadioButtons items + itemType = 'bcRadioButtons => htBcRadioButtons items + itemType = 'inputStrings => htInputStrings items + itemType = 'domainConditions => htProcessDomainConditions items + itemType = 'bcStrings => htProcessBcStrings items + itemType = 'toggleButtons => htProcessToggleButtons items + itemType = 'bcButtons => htProcessBcButtons items + itemType = 'doneButton => htProcessDoneButton items + itemType = 'doitButton => htProcessDoitButton items + systemError ['"unknown itemType", itemType] + +htMakeErrorPage htPage == +------------------> OBSELETE + $newPage := false + $htLineList := nil + $curPage := htPage + htMakePage htpPageDescription htPage + line := APPLY(function CONCAT, nreverse $htLineList) + issueHT line + endHTPage() + +htQuote s == +-- wrap quotes around a piece of hyperTeX + iht '"_"" + iht s + iht '"_"" + +htProcessToggleButtons buttons == + iht '"\newline\indent{5}\beginitems " + for [message, info, defaultValue, buttonName] in buttons repeat + if NULL LASSOC(buttonName, htpInputAreaAlist $curPage) then + setUpDefault(buttonName, ['button, defaultValue]) + iht ['"\item{\em\inputbox[", htpLabelDefault($curPage, buttonName), '"]{", + buttonName, '"}{\htbmfile{pick}}{\htbmfile{unpick}}\space{}"] + bcIssueHt message + iht '"\space{}}" + bcIssueHt info + iht '"\enditems\indent{0} " + +htProcessBcButtons buttons == + for [defaultValue, buttonName] in buttons repeat + if NULL LASSOC(buttonName, htpInputAreaAlist $curPage) then + setUpDefault(buttonName, ['button, defaultValue]) + k := htpLabelDefault($curPage,buttonName) + k = 0 => iht ['"\off{",buttonName,'"}"] + k = 1 => iht ['"\on{", buttonName,'"}"] + iht ['"\inputbox[", htpLabelDefault($curPage, buttonName), '"]{", + buttonName, '"}{\htbmfile{pick}}{\htbmfile{unpick}}"] + +htProcessBcStrings strings == +---------------------> OBSELETE <------------------------ + for [numChars, default, stringName, spadType, :filter] in strings repeat + mess2 := '"" + if NULL LASSOC(stringName, htpInputAreaAlist $curPage) then + setUpDefault(stringName, ['string, default, spadType, filter]) + if htpLabelErrorMsg($curPage, stringName) then + iht ['"\centerline{{\em ", htpLabelErrorMsg($curPage, stringName), '"}}"] + mess2 := CONCAT(mess2, bcSadFaces()) + htpSetLabelErrorMsg($curPage, stringName, nil) + iht ['"\inputstring{", stringName, '"}{", + numChars, '"}{", htpLabelDefault($curPage,stringName), '"} ", mess2] + +bcSadFaces() == + '"\space{1}{\em\htbitmap{error}\htbitmap{error}\htbitmap{error}}" + +htLispLinks(links,:option) == + [links,options] := beforeAfter('options,links) + indent := LASSOC('indent,options) or 5 + iht '"\newline\indent{" + iht stringize indent + iht '"}\beginitems" + for [message, info, func, :value] in links repeat + iht '"\item[" + call := (IFCAR option => '"\lispmemolink"; '"\lispdownlink") + htMakeButton(call,message, mkCurryFun(func, value)) + iht ['"]\space{}"] + bcIssueHt info + iht '"\enditems\indent{0} " + +htLispMemoLinks(links) == htLispLinks(links,true) + +htBcLinks(links,:options) == +-------------------------> OBSELETE + skipStateInfo? := IFCAR options + [links,options] := beforeAfter('options,links) + for [message, info, func, :value] in links repeat + htMakeButton('"\lispdownlink",message, + mkCurryFun(func, value),skipStateInfo?) + bcIssueHt info + +htBcLispLinks links == +-------------------------> OBSELETE + [links,options] := beforeAfter('options,links) + for [message, info, func, :value] in links repeat + htMakeButton('"\lisplink",message, mkCurryFun(func, value)) + bcIssueHt info + +beforeAfter(x,u) == [[y for [y,:r] in tails u while x ^= y],r] + +mkCurryFun(fun, val) == + name := GENTEMP() + code := + ['DEFUN, name, '(arg), ['APPLY, MKQ fun, ['CONS, 'arg, MKQ val]]] + EVAL code + name + +htRadioButtons [groupName, :buttons] == + htpSetRadioButtonAlist($curPage, [[groupName, :buttonNames buttons], + : htpRadioButtonAlist $curPage]) + boxesName := GENTEMP() + iht ['"\newline\indent{5}\radioboxes{", boxesName, + '"}{\htbmfile{pick}}{\htbmfile{unpick}}\beginitems "] + defaultValue := '"1" + for [message, info, buttonName] in buttons repeat + if NULL LASSOC(buttonName, htpInputAreaAlist $curPage) then + setUpDefault(buttonName, ['button, defaultValue]) + defaultValue := '"0" + iht ['"\item{\em\radiobox[", htpLabelDefault($curPage, buttonName), '"]{", + buttonName, '"}{",boxesName, '"}\space{}"] + bcIssueHt message + iht '"\space{}}" + bcIssueHt info + iht '"\enditems\indent{0} " + +htBcRadioButtons [groupName, :buttons] == + htpSetRadioButtonAlist($curPage, [[groupName, :buttonNames buttons], + : htpRadioButtonAlist $curPage]) + boxesName := GENTEMP() + iht ['"\radioboxes{", boxesName, + '"}{\htbmfile{pick}}{\htbmfile{unpick}} "] + defaultValue := '"1" + for [message, info, buttonName] in buttons repeat + if NULL LASSOC(buttonName, htpInputAreaAlist $curPage) then + setUpDefault(buttonName, ['button, defaultValue]) + defaultValue := '"0" + iht ['"{\em\radiobox[", htpLabelDefault($curPage, buttonName), '"]{", + buttonName, '"}{",boxesName, '"}"] + bcIssueHt message + iht '"\space{}}" + bcIssueHt info + +setUpDefault(name, props) == +---------------> OBSELETE <---------------- + htpAddInputAreaProp($curPage, name, props) + +buttonNames buttons == + [buttonName for [.,., buttonName] in buttons] + +htInputStrings strings == + iht '"\newline\indent{5}\beginitems " + for [mess1, mess2, numChars, default, stringName, spadType, :filter] + in strings repeat + if NULL LASSOC(stringName, htpInputAreaAlist $curPage) then + setUpDefault(stringName, ['string, default, spadType, filter]) + if htpLabelErrorMsg($curPage, stringName) then + iht ['"\centerline{{\em ", htpLabelErrorMsg($curPage, stringName), '"}}"] + + mess2 := CONCAT(mess2, bcSadFaces()) + htpSetLabelErrorMsg($curPage, stringName, nil) + iht '"\item " + bcIssueHt mess1 + iht ['"\inputstring{", stringName, '"}{", + numChars, '"}{", htpLabelDefault($curPage,stringName), '"} "] + bcIssueHt mess2 + iht '"\enditems\indent{0}\newline " + +htProcessDomainConditions condList == + htpSetDomainConditions($curPage, renamePatternVariables condList) + htpSetDomainVariableAlist($curPage, computeDomainVariableAlist()) + +renamePatternVariables condList == + htpSetDomainPvarSubstList($curPage, + renamePatternVariables1(condList, nil, $PatternVariableList)) + substFromAlist(condList, htpDomainPvarSubstList $curPage) + +renamePatternVariables1(condList, substList, patVars) == + null condList => substList + [cond, :restConds] := condList + cond is ['isDomain, pv, pattern] or cond is ['ofCategory, pv, pattern] + or cond is ['Satisfies, pv, cond] => + if pv = $EmptyMode then nsubst := substList + else nsubst := [[pv, :car patVars], :substList] + renamePatternVariables1(restConds, nsubst, rest patVars) + substList + +substFromAlist(l, substAlist) == + for [pvar, :replace] in substAlist repeat + l := SUBST(replace, pvar, l) + l + +computeDomainVariableAlist() == + [[pvar, :pvarCondList pvar] for [., :pvar] in + htpDomainPvarSubstList $curPage] + +pvarCondList pvar == + nreverse pvarCondList1([pvar], nil, htpDomainConditions $curPage) + +pvarCondList1(pvarList, activeConds, condList) == + null condList => activeConds + [cond, : restConds] := condList + cond is [., pv, pattern] and pv in pvarList => + pvarCondList1(nconc(pvarList, pvarsOfPattern pattern), + [cond, :activeConds], restConds) + pvarCondList1(pvarList, activeConds, restConds) + +pvarsOfPattern pattern == + NULL LISTP pattern => nil + [pvar for pvar in rest pattern | pvar in $PatternVariableList] + +htMakeTemplates(templateList, numLabels) == + templateList := [templateParts template for template in templateList] + [[substLabel(i, template) for template in templateList] + for i in 1..numLabels] where substLabel(i, template) == + PAIRP template => + INTERN CONCAT(first template, PRINC_-TO_-STRING i, rest template) + template + +templateParts template == + NULL STRINGP template => template + i := SEARCH('"%l", template) + null i => template + [SUBSEQ(template, 0, i), : SUBSEQ(template, i+2)] + +htMakeDoneButton(message, func) == + bcHt '"\newline\vspace{1}\centerline{" + if message = '"Continue" then + bchtMakeButton('"\lispdownlink", "\ContinueBitmap", func) + else + bchtMakeButton('"\lispdownlink",CONCAT('"\box{", message, '"}"), func) + bcHt '"} " + +htProcessDoneButton [label , func] == + iht '"\newline\vspace{1}\centerline{" + + if label = '"Continue" then + htMakeButton('"\lispdownlink", "\ContinueBitmap", func) + else if label = '"Push to enter names" then + htMakeButton('"\lispdownlink",'"\ControlBitmap{ClickToSet}", func) + else + htMakeButton('"\lispdownlink", CONCAT('"\box{", label, '"}"), func) + + iht '"} " + +htMakeButton(htCommand, message, func,:options) == +----------> OBSELETE <---------------------------------- + skipStateInfo? := IFCAR options + iht [htCommand, '"{"] + bcIssueHt message + skipStateInfo? => + iht ['"}{(|htDoneButton| '|", func, '"| ",htpName $curPage, '")}"] + iht ['"}{(|htDoneButton| '|", func, '"| (PROGN "] + for [id, ., ., ., type, :.] in htpInputAreaAlist $curPage repeat + iht ['"(|htpSetLabelInputString| ", htpName $curPage, '"'|", id, '"| "] + if type = 'string then + iht ['"_"\stringvalue{", id, '"}_""] + else + iht ['"_"\boxvalue{", id, '"}_""] + iht '") " + iht [htpName $curPage, '"))}"] + +bchtMakeButton(htCommand, message, func) == + bcHt [htCommand, '"{", message, + '"}{(|htDoneButton| '|", func, '"| (PROGN "] + for [id, ., ., ., type, :.] in htpInputAreaAlist $curPage repeat + bcHt ['"(|htpSetLabelInputString| ", htpName $curPage, '"'|", id, '"| "] + if type = 'string then + bcHt ['"_"\stringvalue{", id, '"}_""] + else + bcHt ['"_"\boxvalue{", id, '"}_""] + bcHt '") " + bcHt [htpName $curPage, '"))} "] + +htProcessDoitButton [label, command, func] == + fun := mkCurryFun(func, [command]) + iht '"\newline\vspace{1}\centerline{" + htMakeButton('"\lispcommand", CONCAT('"\box{", label, '"}"), fun) + iht '"} " + iht '"\vspace{2}{Select \ \UpButton{} \ to go back one page.}" + iht '"\newline{Select \ \ExitButton{QuitPage} \ to remove this window.}" + +htMakeDoitButton(label, command) == + -- use bitmap button if just plain old "Do It" + if label = '"Do It" then + bcHt '"\newline\vspace{1}\centerline{\lispcommand{\DoItBitmap}{(|doDoitButton| " + else + bcHt ['"\newline\vspace{1}\centerline{\lispcommand{\box{", label, + '"}}{(|doDoitButton| "] + bcHt htpName $curPage + bcHt ['" _"", htEscapeString command, '"_""] + bcHt '")}}" + + bcHt '"\vspace{2}{Select \ \UpButton{} \ to go back one page.}" + bcHt '"\newline{Select \ \ExitButton{QuitPage} \ to remove this window.}" + +doDoitButton(htPage, command) == + executeInterpreterCommand command + +executeInterpreterCommand command == + PRINC command + TERPRI() + ncSetCurrentLine(command) + CATCH('SPAD__READER, parseAndInterpret command) + PRINC MKPROMPT() + FINISH_-OUTPUT() + +htDoneButton(func, htPage) == + typeCheckInputAreas htPage => + htMakeErrorPage htPage + NULL FBOUNDP func => + systemError ['"unknown function", func] + FUNCALL(SYMBOL_-FUNCTION func, htPage) + +typeCheckInputAreas htPage == + -- This needs to be severly beefed up + inputAlist := nil + errorCondition := false + for entry in htpInputAreaAlist htPage + | entry is [stringName, ., ., ., 'string, ., spadType, filter] repeat + condList := + LASSOC(LASSOC(spadType,htpDomainPvarSubstList htPage), + htpDomainVariableAlist htPage) + string := htpLabelFilteredInputString(htPage, stringName) + $bcParseOnly => + null ncParseFromString string => + htpSetLabelErrorMsg(htPage, '"Syntax Error", '"Syntax Error") + nil + val := checkCondition(htpLabelInputString(htPage, stringName), + string, condList) + STRINGP val => + errorCondition := true + htpSetLabelErrorMsg(htPage, stringName, val) + htpSetLabelSpadValue(htPage, stringName, val) + errorCondition + +checkCondition(s1, string, condList) == + condList is [['Satisfies, pvar, pred]] => + val := FUNCALL(pred, string) + STRINGP val => val + ['(String), :wrap s1] + condList isnt [['isDomain, pvar, pattern]] => + systemError '"currently invalid domain condition" + pattern is '(String) => ['(String), :wrap s1] + val := parseAndEval string + STRINGP val => + val = '"Syntax Error " => '"Error: Syntax Error " + condErrorMsg pattern + [type, : data] := val + newType := CATCH('SPAD__READER, resolveTM(type, pattern)) + null newType => + condErrorMsg pattern + coerceInt(val, newType) + +condErrorMsg type == + typeString := form2String type + if PAIRP typeString then typeString := APPLY(function CONCAT, typeString) + CONCAT('"Error: Could not make your input into a ", typeString) + +parseAndEval string == + $InteractiveMode :fluid := true + $BOOT: fluid := NIL + $SPAD: fluid := true + $e:fluid := $InteractiveFrame + $QuietCommand:local := true + parseAndEval1 string + +parseAndEval1 string == + syntaxError := false + pform := + $useNewParser => + v := applyWithOutputToString('ncParseFromString, [string]) + CAR v => CAR v + syntaxError := true + CDR v + oldParseString string + syntaxError => + '"Syntax Error " + pform => + val := applyWithOutputToString('processInteractive, [pform, nil]) + CAR val => CAR val + '"Type Analysis Error" + nil + +oldParseString string == + tree := applyWithOutputToString('string2SpadTree, [string]) + CAR tree => parseTransform postTransform CAR tree + CDR tree + +makeSpadCommand(:l) == + opForm := CONCAT(first l, '"(") + lastArg := last l + l := rest l + argList := nil + for arg in l while arg ^= lastArg repeat + argList := [CONCAT(arg, '", "), :argList] + argList := nreverse [lastArg, :argList] + CONCAT(opForm, APPLY(function CONCAT, argList), '")") + +htMakeInputList stringList == +-- makes an input form for constructing a list + lastArg := last stringList + argList := nil + for arg in stringList while arg ^= lastArg repeat + argList := [CONCAT(arg, '", "), :argList] + argList := nreverse [lastArg, :argList] + bracketString APPLY(function CONCAT, argList) + + +-- predefined filter strings +bracketString string == CONCAT('"[",string,'"]") + +quoteString string == CONCAT('"_"", string, '"_"") + +$funnyQuote := char 127 +$funnyBacks := char 128 + +htEscapeString str == + str := SUBSTITUTE($funnyQuote, char '_", str) + SUBSTITUTE($funnyBacks, char '_\, str) + +unescapeStringsInForm form == + STRINGP form => + str := NSUBSTITUTE(char '_", $funnyQuote, form) + NSUBSTITUTE(char '_\, $funnyBacks, str) + CONSP form => + unescapeStringsInForm CAR form + unescapeStringsInForm CDR form + form + form + + + + + diff --git a/src/interp/ht-util.boot.pamphlet b/src/interp/ht-util.boot.pamphlet deleted file mode 100644 index 4e5de6aa..00000000 --- a/src/interp/ht-util.boot.pamphlet +++ /dev/null @@ -1,755 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp ht-util.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\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. - -@ -<<*>>= -<> - -import '"macros" -)package "BOOT" - --- HyperTeX Utilities for generating basic Command pages - -$bcParseOnly := true - --- List of issued hypertex lines -$htLineList := nil - --- pointer to the page we are currently defining -$curPage := nil - --- List of currently active window named -$activePageList := nil - -htpDestroyPage(pageName) == - pageName in $activePageList => - SET(pageName, nil) - $activePageList := NREMOVE($activePageList, pageName) - -htpName htPage == --- GENSYM whose value is the page - ELT(htPage, 0) - -htpSetName(htPage, val) == - SETELT(htPage, 0, val) - -htpDomainConditions htPage == --- List of Domain conditions - ELT(htPage, 1) - -htpSetDomainConditions(htPage, val) == - SETELT(htPage, 1, val) - -htpDomainVariableAlist htPage == --- alist of pattern variables and conditions - ELT(htPage, 2) - -htpSetDomainVariableAlist(htPage, val) == - SETELT(htPage, 2, val) - -htpDomainPvarSubstList htPage == --- alist of user pattern variables to system vars - ELT(htPage, 3) - -htpSetDomainPvarSubstList(htPage, val) == - SETELT(htPage, 3, val) - -htpRadioButtonAlist htPage == --- alist of radio button group names and labels - ELT(htPage, 4) - -htpButtonValue(htPage, groupName) == - for buttonName in LASSOC(groupName, htpRadioButtonAlist htPage) repeat - (stripSpaces htpLabelInputString(htPage, buttonName)) = '"t" => - return buttonName - -htpSetRadioButtonAlist(htPage, val) == - SETELT(htPage, 4, val) - -htpInputAreaAlist htPage == --- Alist of input-area labels, and default values - ELT(htPage, 5) - -htpSetInputAreaAlist(htPage, val) == - SETELT(htPage, 5, val) - -htpAddInputAreaProp(htPage, label, prop) == - SETELT(htPage, 5, [[label, nil, nil, nil, :prop], :ELT(htPage, 5)]) - -htpPropertyList htPage == --- Association list of user-defined properties - ELT(htPage, 6) - -htpProperty(htPage, propName) == - LASSOC(propName, ELT(htPage, 6)) - -htpSetProperty(htPage, propName, val) == - pair := assoc(propName, ELT(htPage, 6)) - pair => RPLACD(pair, val) - SETELT(htPage, 6, [[propName, :val], :ELT(htPage, 6)]) - -htpLabelInputString(htPage, label) == --- value user typed as input string on page - props := LASSOC(label, htpInputAreaAlist htPage) - props and STRINGP (s := ELT(props,0)) => - s = '"" => s - trimString s - nil - -htpLabelFilteredInputString(htPage, label) == --- value user typed as input string on page - props := LASSOC(label, htpInputAreaAlist htPage) - props => - #props > 5 and ELT(props, 6) => - FUNCALL(SYMBOL_-FUNCTION ELT(props, 6), ELT(props, 0)) - replacePercentByDollar ELT(props, 0) - nil - -replacePercentByDollar s == fn(s,0,MAXINDEX s) where - fn(s,i,n) == - i > n => '"" - (m := charPosition(char "%",s,i)) > n => SUBSTRING(s,i,nil) - STRCONC(SUBSTRING(s,i,m - i),'"$",fn(s,m + 1,n)) - -htpSetLabelInputString(htPage, label, val) == -------------------> OBSELETE --- value user typed as input string on page - props := LASSOC(label, htpInputAreaAlist htPage) - props => SETELT(props, 0, STRINGIMAGE val) - nil - -htpLabelSpadValue(htPage, label) == --- Scratchpad value of parsed and evaled inputString, as (type . value) - props := LASSOC(label, htpInputAreaAlist htPage) - props => ELT(props, 1) - nil - -htpSetLabelSpadValue(htPage, label, val) == --- value user typed as input string on page - props := LASSOC(label, htpInputAreaAlist htPage) - props => SETELT(props, 1, val) - nil - -htpLabelErrorMsg(htPage, label) == --- error message associated with input area - props := LASSOC(label, htpInputAreaAlist htPage) - props => ELT(props, 2) - nil - -htpSetLabelErrorMsg(htPage, label, val) == --- error message associated with input area - props := LASSOC(label, htpInputAreaAlist htPage) - props => SETELT(props, 2, val) - nil - -htpLabelType(htPage, label) == --- either 'string or 'button - props := LASSOC(label, htpInputAreaAlist htPage) - props => ELT(props, 3) - nil - -htpLabelDefault(htPage, label) == --- default value for the input area - msg := htpLabelInputString(htPage, label) => - msg = '"t" => 1 - msg = '"nil" => 0 - msg - props := LASSOC(label, htpInputAreaAlist htPage) - props => - ELT(props, 4) - nil - - -htpLabelSpadType(htPage, label) == --- pattern variable for target domain for input area - props := LASSOC(label, htpInputAreaAlist htPage) - props => ELT(props, 5) - nil - -htpLabelFilter(htPage, label) == --- string to string mapping applied to input area strings before parsing - props := LASSOC(label, htpInputAreaAlist htPage) - props => ELT(props, 6) - nil - -htpPageDescription htPage == --- a list of all the commands issued to create the basic-command page - ELT(htPage, 7) - -htpSetPageDescription(htPage, pageDescription) == - SETELT(htPage, 7, pageDescription) - -htpAddToPageDescription(htPage, pageDescrip) == --------------> OBSELETE <----------- - SETELT(htPage, 7, nconc(nreverse COPY_-LIST pageDescrip, ELT(htPage, 7))) - -iht line == --- issue a single hyperteTeX line, or a group of lines - $newPage => nil - PAIRP line => - $htLineList := NCONC(nreverse mapStringize COPY_-LIST line, $htLineList) - $htLineList := [basicStringize line, :$htLineList] - -bcHt line == ---line = '"\##1" => harharhar() - iht line - PAIRP line => - if $newPage then htpAddToPageDescription($curPage, [['text, :line]]) - if $newPage then htpAddToPageDescription($curPage, [['text, line]]) - -bcIssueHt line == - PAIRP line => htMakePage1 line - iht line - -mapStringize l == - ATOM l => l - RPLACA(l, basicStringize CAR l) - RPLACD(l, mapStringize CDR l) - l - -basicStringize s == - STRINGP s => - s = '"\$" => '"\%" - s = '"{\em $}" => '"{\em \%}" - s - s = '_$ => '"\%" - PRINC_-TO_-STRING s - -stringize s == - STRINGP s => s - PRINC_-TO_-STRING s - -htInitPage(title, propList) == -----------------------------> OBSELETE---cannot return $curPage --- start defining a hyperTeX page - htInitPageNoScroll(propList, title) - htSayStandard '"\beginscroll " - $curPage - - ---htInitPageNoHeading(propList) == ------------------------> replaced by htInitPageNoScroll --- start defining a hyperTeX page --- $curPage := htpMakeEmptyPage(propList) --- if $saturn then $saturnPage := htpMakeEmptyPage(propList) --- $newPage := true --- $htLineList := nil --- $curPage - -htAddHeading(title) == -------------------------> OBSELETE - htNewPage title - $curPage - -htShowPage() == --- show the page which has been computed - htSayStandard '"\endscroll" - htShowPageNoScroll() - -htShowPageNoScroll() == -------------------------> OBSELETE --- show the page which has been computed - htSayStandard '"\autobuttons" - htpSetPageDescription($curPage, nreverse htpPageDescription $curPage) - $newPage := false - $htLineList := nil - htMakePage htpPageDescription $curPage - line := APPLY(function CONCAT, nreverse $htLineList) - issueHT line - endHTPage() - -htMakePage itemList == -------------------------> OBSELETE --- make a page given the description in itemList - if $newPage then htpAddToPageDescription($curPage, itemList) - htMakePage1 itemList - -htMakePage1 itemList == --- make a page given the description in itemList - for [itemType, :items] in itemList repeat - itemType = 'text => iht items - itemType = 'lispLinks => htLispLinks items - itemType = 'lispmemoLinks => htLispMemoLinks items - itemType = 'bcLinks => htBcLinks items ---> - itemType = 'bcLinksNS => htBcLinks(items,true) - itemType = 'bcLispLinks => htBcLispLinks items ---> - itemType = 'radioButtons => htRadioButtons items - itemType = 'bcRadioButtons => htBcRadioButtons items - itemType = 'inputStrings => htInputStrings items - itemType = 'domainConditions => htProcessDomainConditions items - itemType = 'bcStrings => htProcessBcStrings items - itemType = 'toggleButtons => htProcessToggleButtons items - itemType = 'bcButtons => htProcessBcButtons items - itemType = 'doneButton => htProcessDoneButton items - itemType = 'doitButton => htProcessDoitButton items - systemError ['"unknown itemType", itemType] - -htMakeErrorPage htPage == -------------------> OBSELETE - $newPage := false - $htLineList := nil - $curPage := htPage - htMakePage htpPageDescription htPage - line := APPLY(function CONCAT, nreverse $htLineList) - issueHT line - endHTPage() - -htQuote s == --- wrap quotes around a piece of hyperTeX - iht '"_"" - iht s - iht '"_"" - -htProcessToggleButtons buttons == - iht '"\newline\indent{5}\beginitems " - for [message, info, defaultValue, buttonName] in buttons repeat - if NULL LASSOC(buttonName, htpInputAreaAlist $curPage) then - setUpDefault(buttonName, ['button, defaultValue]) - iht ['"\item{\em\inputbox[", htpLabelDefault($curPage, buttonName), '"]{", - buttonName, '"}{\htbmfile{pick}}{\htbmfile{unpick}}\space{}"] - bcIssueHt message - iht '"\space{}}" - bcIssueHt info - iht '"\enditems\indent{0} " - -htProcessBcButtons buttons == - for [defaultValue, buttonName] in buttons repeat - if NULL LASSOC(buttonName, htpInputAreaAlist $curPage) then - setUpDefault(buttonName, ['button, defaultValue]) - k := htpLabelDefault($curPage,buttonName) - k = 0 => iht ['"\off{",buttonName,'"}"] - k = 1 => iht ['"\on{", buttonName,'"}"] - iht ['"\inputbox[", htpLabelDefault($curPage, buttonName), '"]{", - buttonName, '"}{\htbmfile{pick}}{\htbmfile{unpick}}"] - -htProcessBcStrings strings == ----------------------> OBSELETE <------------------------ - for [numChars, default, stringName, spadType, :filter] in strings repeat - mess2 := '"" - if NULL LASSOC(stringName, htpInputAreaAlist $curPage) then - setUpDefault(stringName, ['string, default, spadType, filter]) - if htpLabelErrorMsg($curPage, stringName) then - iht ['"\centerline{{\em ", htpLabelErrorMsg($curPage, stringName), '"}}"] - mess2 := CONCAT(mess2, bcSadFaces()) - htpSetLabelErrorMsg($curPage, stringName, nil) - iht ['"\inputstring{", stringName, '"}{", - numChars, '"}{", htpLabelDefault($curPage,stringName), '"} ", mess2] - -bcSadFaces() == - '"\space{1}{\em\htbitmap{error}\htbitmap{error}\htbitmap{error}}" - -htLispLinks(links,:option) == - [links,options] := beforeAfter('options,links) - indent := LASSOC('indent,options) or 5 - iht '"\newline\indent{" - iht stringize indent - iht '"}\beginitems" - for [message, info, func, :value] in links repeat - iht '"\item[" - call := (IFCAR option => '"\lispmemolink"; '"\lispdownlink") - htMakeButton(call,message, mkCurryFun(func, value)) - iht ['"]\space{}"] - bcIssueHt info - iht '"\enditems\indent{0} " - -htLispMemoLinks(links) == htLispLinks(links,true) - -htBcLinks(links,:options) == --------------------------> OBSELETE - skipStateInfo? := IFCAR options - [links,options] := beforeAfter('options,links) - for [message, info, func, :value] in links repeat - htMakeButton('"\lispdownlink",message, - mkCurryFun(func, value),skipStateInfo?) - bcIssueHt info - -htBcLispLinks links == --------------------------> OBSELETE - [links,options] := beforeAfter('options,links) - for [message, info, func, :value] in links repeat - htMakeButton('"\lisplink",message, mkCurryFun(func, value)) - bcIssueHt info - -beforeAfter(x,u) == [[y for [y,:r] in tails u while x ^= y],r] - -mkCurryFun(fun, val) == - name := GENTEMP() - code := - ['DEFUN, name, '(arg), ['APPLY, MKQ fun, ['CONS, 'arg, MKQ val]]] - EVAL code - name - -htRadioButtons [groupName, :buttons] == - htpSetRadioButtonAlist($curPage, [[groupName, :buttonNames buttons], - : htpRadioButtonAlist $curPage]) - boxesName := GENTEMP() - iht ['"\newline\indent{5}\radioboxes{", boxesName, - '"}{\htbmfile{pick}}{\htbmfile{unpick}}\beginitems "] - defaultValue := '"1" - for [message, info, buttonName] in buttons repeat - if NULL LASSOC(buttonName, htpInputAreaAlist $curPage) then - setUpDefault(buttonName, ['button, defaultValue]) - defaultValue := '"0" - iht ['"\item{\em\radiobox[", htpLabelDefault($curPage, buttonName), '"]{", - buttonName, '"}{",boxesName, '"}\space{}"] - bcIssueHt message - iht '"\space{}}" - bcIssueHt info - iht '"\enditems\indent{0} " - -htBcRadioButtons [groupName, :buttons] == - htpSetRadioButtonAlist($curPage, [[groupName, :buttonNames buttons], - : htpRadioButtonAlist $curPage]) - boxesName := GENTEMP() - iht ['"\radioboxes{", boxesName, - '"}{\htbmfile{pick}}{\htbmfile{unpick}} "] - defaultValue := '"1" - for [message, info, buttonName] in buttons repeat - if NULL LASSOC(buttonName, htpInputAreaAlist $curPage) then - setUpDefault(buttonName, ['button, defaultValue]) - defaultValue := '"0" - iht ['"{\em\radiobox[", htpLabelDefault($curPage, buttonName), '"]{", - buttonName, '"}{",boxesName, '"}"] - bcIssueHt message - iht '"\space{}}" - bcIssueHt info - -setUpDefault(name, props) == ----------------> OBSELETE <---------------- - htpAddInputAreaProp($curPage, name, props) - -buttonNames buttons == - [buttonName for [.,., buttonName] in buttons] - -htInputStrings strings == - iht '"\newline\indent{5}\beginitems " - for [mess1, mess2, numChars, default, stringName, spadType, :filter] - in strings repeat - if NULL LASSOC(stringName, htpInputAreaAlist $curPage) then - setUpDefault(stringName, ['string, default, spadType, filter]) - if htpLabelErrorMsg($curPage, stringName) then - iht ['"\centerline{{\em ", htpLabelErrorMsg($curPage, stringName), '"}}"] - - mess2 := CONCAT(mess2, bcSadFaces()) - htpSetLabelErrorMsg($curPage, stringName, nil) - iht '"\item " - bcIssueHt mess1 - iht ['"\inputstring{", stringName, '"}{", - numChars, '"}{", htpLabelDefault($curPage,stringName), '"} "] - bcIssueHt mess2 - iht '"\enditems\indent{0}\newline " - -htProcessDomainConditions condList == - htpSetDomainConditions($curPage, renamePatternVariables condList) - htpSetDomainVariableAlist($curPage, computeDomainVariableAlist()) - -renamePatternVariables condList == - htpSetDomainPvarSubstList($curPage, - renamePatternVariables1(condList, nil, $PatternVariableList)) - substFromAlist(condList, htpDomainPvarSubstList $curPage) - -renamePatternVariables1(condList, substList, patVars) == - null condList => substList - [cond, :restConds] := condList - cond is ['isDomain, pv, pattern] or cond is ['ofCategory, pv, pattern] - or cond is ['Satisfies, pv, cond] => - if pv = $EmptyMode then nsubst := substList - else nsubst := [[pv, :car patVars], :substList] - renamePatternVariables1(restConds, nsubst, rest patVars) - substList - -substFromAlist(l, substAlist) == - for [pvar, :replace] in substAlist repeat - l := SUBST(replace, pvar, l) - l - -computeDomainVariableAlist() == - [[pvar, :pvarCondList pvar] for [., :pvar] in - htpDomainPvarSubstList $curPage] - -pvarCondList pvar == - nreverse pvarCondList1([pvar], nil, htpDomainConditions $curPage) - -pvarCondList1(pvarList, activeConds, condList) == - null condList => activeConds - [cond, : restConds] := condList - cond is [., pv, pattern] and pv in pvarList => - pvarCondList1(nconc(pvarList, pvarsOfPattern pattern), - [cond, :activeConds], restConds) - pvarCondList1(pvarList, activeConds, restConds) - -pvarsOfPattern pattern == - NULL LISTP pattern => nil - [pvar for pvar in rest pattern | pvar in $PatternVariableList] - -htMakeTemplates(templateList, numLabels) == - templateList := [templateParts template for template in templateList] - [[substLabel(i, template) for template in templateList] - for i in 1..numLabels] where substLabel(i, template) == - PAIRP template => - INTERN CONCAT(first template, PRINC_-TO_-STRING i, rest template) - template - -templateParts template == - NULL STRINGP template => template - i := SEARCH('"%l", template) - null i => template - [SUBSEQ(template, 0, i), : SUBSEQ(template, i+2)] - -htMakeDoneButton(message, func) == - bcHt '"\newline\vspace{1}\centerline{" - if message = '"Continue" then - bchtMakeButton('"\lispdownlink", "\ContinueBitmap", func) - else - bchtMakeButton('"\lispdownlink",CONCAT('"\box{", message, '"}"), func) - bcHt '"} " - -htProcessDoneButton [label , func] == - iht '"\newline\vspace{1}\centerline{" - - if label = '"Continue" then - htMakeButton('"\lispdownlink", "\ContinueBitmap", func) - else if label = '"Push to enter names" then - htMakeButton('"\lispdownlink",'"\ControlBitmap{ClickToSet}", func) - else - htMakeButton('"\lispdownlink", CONCAT('"\box{", label, '"}"), func) - - iht '"} " - -htMakeButton(htCommand, message, func,:options) == -----------> OBSELETE <---------------------------------- - skipStateInfo? := IFCAR options - iht [htCommand, '"{"] - bcIssueHt message - skipStateInfo? => - iht ['"}{(|htDoneButton| '|", func, '"| ",htpName $curPage, '")}"] - iht ['"}{(|htDoneButton| '|", func, '"| (PROGN "] - for [id, ., ., ., type, :.] in htpInputAreaAlist $curPage repeat - iht ['"(|htpSetLabelInputString| ", htpName $curPage, '"'|", id, '"| "] - if type = 'string then - iht ['"_"\stringvalue{", id, '"}_""] - else - iht ['"_"\boxvalue{", id, '"}_""] - iht '") " - iht [htpName $curPage, '"))}"] - -bchtMakeButton(htCommand, message, func) == - bcHt [htCommand, '"{", message, - '"}{(|htDoneButton| '|", func, '"| (PROGN "] - for [id, ., ., ., type, :.] in htpInputAreaAlist $curPage repeat - bcHt ['"(|htpSetLabelInputString| ", htpName $curPage, '"'|", id, '"| "] - if type = 'string then - bcHt ['"_"\stringvalue{", id, '"}_""] - else - bcHt ['"_"\boxvalue{", id, '"}_""] - bcHt '") " - bcHt [htpName $curPage, '"))} "] - -htProcessDoitButton [label, command, func] == - fun := mkCurryFun(func, [command]) - iht '"\newline\vspace{1}\centerline{" - htMakeButton('"\lispcommand", CONCAT('"\box{", label, '"}"), fun) - iht '"} " - iht '"\vspace{2}{Select \ \UpButton{} \ to go back one page.}" - iht '"\newline{Select \ \ExitButton{QuitPage} \ to remove this window.}" - -htMakeDoitButton(label, command) == - -- use bitmap button if just plain old "Do It" - if label = '"Do It" then - bcHt '"\newline\vspace{1}\centerline{\lispcommand{\DoItBitmap}{(|doDoitButton| " - else - bcHt ['"\newline\vspace{1}\centerline{\lispcommand{\box{", label, - '"}}{(|doDoitButton| "] - bcHt htpName $curPage - bcHt ['" _"", htEscapeString command, '"_""] - bcHt '")}}" - - bcHt '"\vspace{2}{Select \ \UpButton{} \ to go back one page.}" - bcHt '"\newline{Select \ \ExitButton{QuitPage} \ to remove this window.}" - -doDoitButton(htPage, command) == - executeInterpreterCommand command - -executeInterpreterCommand command == - PRINC command - TERPRI() - ncSetCurrentLine(command) - CATCH('SPAD__READER, parseAndInterpret command) - PRINC MKPROMPT() - FINISH_-OUTPUT() - -htDoneButton(func, htPage) == - typeCheckInputAreas htPage => - htMakeErrorPage htPage - NULL FBOUNDP func => - systemError ['"unknown function", func] - FUNCALL(SYMBOL_-FUNCTION func, htPage) - -typeCheckInputAreas htPage == - -- This needs to be severly beefed up - inputAlist := nil - errorCondition := false - for entry in htpInputAreaAlist htPage - | entry is [stringName, ., ., ., 'string, ., spadType, filter] repeat - condList := - LASSOC(LASSOC(spadType,htpDomainPvarSubstList htPage), - htpDomainVariableAlist htPage) - string := htpLabelFilteredInputString(htPage, stringName) - $bcParseOnly => - null ncParseFromString string => - htpSetLabelErrorMsg(htPage, '"Syntax Error", '"Syntax Error") - nil - val := checkCondition(htpLabelInputString(htPage, stringName), - string, condList) - STRINGP val => - errorCondition := true - htpSetLabelErrorMsg(htPage, stringName, val) - htpSetLabelSpadValue(htPage, stringName, val) - errorCondition - -checkCondition(s1, string, condList) == - condList is [['Satisfies, pvar, pred]] => - val := FUNCALL(pred, string) - STRINGP val => val - ['(String), :wrap s1] - condList isnt [['isDomain, pvar, pattern]] => - systemError '"currently invalid domain condition" - pattern is '(String) => ['(String), :wrap s1] - val := parseAndEval string - STRINGP val => - val = '"Syntax Error " => '"Error: Syntax Error " - condErrorMsg pattern - [type, : data] := val - newType := CATCH('SPAD__READER, resolveTM(type, pattern)) - null newType => - condErrorMsg pattern - coerceInt(val, newType) - -condErrorMsg type == - typeString := form2String type - if PAIRP typeString then typeString := APPLY(function CONCAT, typeString) - CONCAT('"Error: Could not make your input into a ", typeString) - -parseAndEval string == - $InteractiveMode :fluid := true - $BOOT: fluid := NIL - $SPAD: fluid := true - $e:fluid := $InteractiveFrame - $QuietCommand:local := true - parseAndEval1 string - -parseAndEval1 string == - syntaxError := false - pform := - $useNewParser => - v := applyWithOutputToString('ncParseFromString, [string]) - CAR v => CAR v - syntaxError := true - CDR v - oldParseString string - syntaxError => - '"Syntax Error " - pform => - val := applyWithOutputToString('processInteractive, [pform, nil]) - CAR val => CAR val - '"Type Analysis Error" - nil - -oldParseString string == - tree := applyWithOutputToString('string2SpadTree, [string]) - CAR tree => parseTransform postTransform CAR tree - CDR tree - -makeSpadCommand(:l) == - opForm := CONCAT(first l, '"(") - lastArg := last l - l := rest l - argList := nil - for arg in l while arg ^= lastArg repeat - argList := [CONCAT(arg, '", "), :argList] - argList := nreverse [lastArg, :argList] - CONCAT(opForm, APPLY(function CONCAT, argList), '")") - -htMakeInputList stringList == --- makes an input form for constructing a list - lastArg := last stringList - argList := nil - for arg in stringList while arg ^= lastArg repeat - argList := [CONCAT(arg, '", "), :argList] - argList := nreverse [lastArg, :argList] - bracketString APPLY(function CONCAT, argList) - - --- predefined filter strings -bracketString string == CONCAT('"[",string,'"]") - -quoteString string == CONCAT('"_"", string, '"_"") - -$funnyQuote := char 127 -$funnyBacks := char 128 - -htEscapeString str == - str := SUBSTITUTE($funnyQuote, char '_", str) - SUBSTITUTE($funnyBacks, char '_\, str) - -unescapeStringsInForm form == - STRINGP form => - str := NSUBSTITUTE(char '_", $funnyQuote, form) - NSUBSTITUTE(char '_\, $funnyBacks, str) - CONSP form => - unescapeStringsInForm CAR form - unescapeStringsInForm CDR form - form - form - - - - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/htcheck.boot b/src/interp/htcheck.boot new file mode 100644 index 00000000..39fa49bb --- /dev/null +++ b/src/interp/htcheck.boot @@ -0,0 +1,133 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- 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. + + +import '"sys-driver" +import '"macros" +)package "BOOT" + +$primitiveHtCommands := '( + ("\ContinueButton" . 1) + ("\andexample" . 1) + ("\autobutt" . 0) + ("\autobuttons". 0) + ("\begin" . 1) + ("\beginscroll". 0) + ("\bound" . 1) + ("\fbox" . 1) + ("\centerline" . 1) + ("\downlink" . 2) + ("\em" . 0) + ("\end" . 1) + ("\endscroll" . 0) + ("\example" . 1) + ("\free" . 1) + ("\graphpaste" . 1) + ("\helppage" . 1) + ("\htbmdir" . 0) + ("\htbmfile" . 1) + ("\indent" . 1) + ("\inputbitmap" . 1) + ("\inputstring" . 3) + ("\item" . 0) + ("\keyword" . 1) + ("\link" . 2) + ("\lispdownlink" . 2) + ("\lispmemolink" . 2) + ("\lispwindowlink" . 2) + ("\menudownlink" . 2) + ("\menuitemstyle" . 1) + ("\menulink" . 2) + ("\menulispdownlink" . 2) + ("\menulispmemolink" . 2) + ("\menulispwindowlink" . 2) + ("\menumemolink" . 2) + ("\menuwindowlink" . 2) + ("\newline" . 0) + ("\radioboxes" . 3) + ("\space" . 1) + ("\spadcommand" . 1) + ("\stringvalue" . 1) + ("\tab" . 1) + ("\table" . 1) + ("\vspace" . 1) + ("\windowlink" . 2)) + +buildHtMacroTable() == + $htMacroTable := MAKE_-HASHTABLE 'UEQUAL + fn := CONCAT(systemRootDirectory(), '"/share/hypertex/pages/util.ht") + if PROBE_-FILE(fn) then + instream := MAKE_-INSTREAM fn + while not EOFP instream repeat + line := READLINE instream + getHtMacroItem line is [string,:numOfArgs] => + HPUT($htMacroTable,string,numOfArgs) + for [s,:n] in $primitiveHtCommands repeat HPUT($htMacroTable,s,n) + else + sayBrightly '"Warning: macro table not found" + $htMacroTable + +getHtMacroItem line == + null stringPrefix?('"\newcommand{",line) => nil + k := charPosition(char '_},line,11) + command := SUBSTRING(line,12,k - 12) + numOfArgs := + m := #line + i := charPosition(char '_[,line,k) + i = m => 0 + j := charPosition(char '_],line,i + 1) + digitString := SUBSTRING(line,i + 1,j - i - 1) + and/[DIGITP digitString.i for i in 0..MAXINDEX digitString] + => PARSE_-INTEGER digitString + return nil + [command,:numOfArgs] + +spadSysChoose(tree,form) == --tree is ((word . tree) ..) + null form => true + null tree => false + lookupOn := + form is [key,arg] => key + form + newTree := LASSOC(lookupOn,tree) => spadSysBranch(newTree,IFCAR IFCDR form) + false + +spadSysBranch(tree,arg) == --tree is (msg kind TREEorSomethingElse ...) + null arg => true + kind := tree.2 + kind = 'TREE => spadSysChoose(tree.4,arg) + kind = 'LITERALS => member(arg,tree.4) + kind = 'INTEGER => INTEGERP arg + kind = 'FUNCTION => atom arg + systemError '"unknown tree branch" + +buildHtMacroTable() diff --git a/src/interp/htcheck.boot.pamphlet b/src/interp/htcheck.boot.pamphlet deleted file mode 100644 index 82f67b3a..00000000 --- a/src/interp/htcheck.boot.pamphlet +++ /dev/null @@ -1,157 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/htcheck.boot} Pamphlet} -\author{The Axiom Team} - -\begin{document} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\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. - -@ -<<*>>= -<> - -import '"sys-driver" -import '"macros" -)package "BOOT" - -$primitiveHtCommands := '( - ("\ContinueButton" . 1) - ("\andexample" . 1) - ("\autobutt" . 0) - ("\autobuttons". 0) - ("\begin" . 1) - ("\beginscroll". 0) - ("\bound" . 1) - ("\fbox" . 1) - ("\centerline" . 1) - ("\downlink" . 2) - ("\em" . 0) - ("\end" . 1) - ("\endscroll" . 0) - ("\example" . 1) - ("\free" . 1) - ("\graphpaste" . 1) - ("\helppage" . 1) - ("\htbmdir" . 0) - ("\htbmfile" . 1) - ("\indent" . 1) - ("\inputbitmap" . 1) - ("\inputstring" . 3) - ("\item" . 0) - ("\keyword" . 1) - ("\link" . 2) - ("\lispdownlink" . 2) - ("\lispmemolink" . 2) - ("\lispwindowlink" . 2) - ("\menudownlink" . 2) - ("\menuitemstyle" . 1) - ("\menulink" . 2) - ("\menulispdownlink" . 2) - ("\menulispmemolink" . 2) - ("\menulispwindowlink" . 2) - ("\menumemolink" . 2) - ("\menuwindowlink" . 2) - ("\newline" . 0) - ("\radioboxes" . 3) - ("\space" . 1) - ("\spadcommand" . 1) - ("\stringvalue" . 1) - ("\tab" . 1) - ("\table" . 1) - ("\vspace" . 1) - ("\windowlink" . 2)) - -buildHtMacroTable() == - $htMacroTable := MAKE_-HASHTABLE 'UEQUAL - fn := CONCAT(systemRootDirectory(), '"/share/hypertex/pages/util.ht") - if PROBE_-FILE(fn) then - instream := MAKE_-INSTREAM fn - while not EOFP instream repeat - line := READLINE instream - getHtMacroItem line is [string,:numOfArgs] => - HPUT($htMacroTable,string,numOfArgs) - for [s,:n] in $primitiveHtCommands repeat HPUT($htMacroTable,s,n) - else - sayBrightly '"Warning: macro table not found" - $htMacroTable - -getHtMacroItem line == - null stringPrefix?('"\newcommand{",line) => nil - k := charPosition(char '_},line,11) - command := SUBSTRING(line,12,k - 12) - numOfArgs := - m := #line - i := charPosition(char '_[,line,k) - i = m => 0 - j := charPosition(char '_],line,i + 1) - digitString := SUBSTRING(line,i + 1,j - i - 1) - and/[DIGITP digitString.i for i in 0..MAXINDEX digitString] - => PARSE_-INTEGER digitString - return nil - [command,:numOfArgs] - -spadSysChoose(tree,form) == --tree is ((word . tree) ..) - null form => true - null tree => false - lookupOn := - form is [key,arg] => key - form - newTree := LASSOC(lookupOn,tree) => spadSysBranch(newTree,IFCAR IFCDR form) - false - -spadSysBranch(tree,arg) == --tree is (msg kind TREEorSomethingElse ...) - null arg => true - kind := tree.2 - kind = 'TREE => spadSysChoose(tree.4,arg) - kind = 'LITERALS => member(arg,tree.4) - kind = 'INTEGER => INTEGERP arg - kind = 'FUNCTION => atom arg - systemError '"unknown tree branch" - -buildHtMacroTable() -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/htsetvar.boot b/src/interp/htsetvar.boot new file mode 100644 index 00000000..a563645e --- /dev/null +++ b/src/interp/htsetvar.boot @@ -0,0 +1,483 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- 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. + + +import '"macros" +)package "BOOT" + +htsv() == + startHTPage(50) + htSetVars() + +htSetVars() == + $path := nil + $lastTree := nil + if 0 ^= LASTATOM $setOptions then htMarkTree($setOptions,0) + htShowSetTree($setOptions) + +htShowSetTree(setTree) == + $path := TAKE(- LASTATOM setTree,$path) + page := htInitPage(mkSetTitle(),nil) + htpSetProperty(page, 'setTree, setTree) + links := nil + maxWidth1 := maxWidth2 := 0 + for setData in setTree repeat + satisfiesUserLevel setData.setLevel => + okList := [setData,:okList] + maxWidth1 := MAX(# PNAME setData.setName,maxWidth1) + maxWidth2 := MAX(htShowCount STRINGIMAGE setData.setLabel,maxWidth2) + maxWidth1 := MAX(9,maxWidth1) + maxWidth2 := MAX(41,maxWidth2) + tabset1 := STRINGIMAGE (maxWidth1) + tabset2 := STRINGIMAGE (maxWidth2 + maxWidth1 - 1) + htSay('"\tab{2}\newline Variable\tab{",STRINGIMAGE (maxWidth1 + (maxWidth2/3)),'"}Description\tab{",STRINGIMAGE(maxWidth2 + maxWidth1 + 2),'"}Value\newline\beginitems ") + for setData in REVERSE okList repeat + htSay '"\item" + label := STRCONC('"\menuitemstyle{",setData.setName,'"}") + links := [label,[['text,'"\tab{",tabset1,'"}",setData.setLabel,'"\tab{",tabset2,'"}{\em ",htShowSetTreeValue setData,'"}"]], + 'htShowSetPage, setData.setName] + htMakePage [['bcLispLinks, links,'options,'(indent . 0)]] + htSay '"\enditems" + htShowPage() + +htShowCount s == --# discounting {\em .. } + m := #s + m < 8 => m - 1 + i := 0 + count := 0 + while i < m - 7 repeat + s.i = char '_{ and s.(i+1) = char '_\ and s.(i+2) = char 'e + and s.(i+3) = char 'm => i := i + 6 --discount {\em } + i := i + 1 + count := count + 1 + count + (m - i) + +htShowSetTreeValue(setData) == + st := setData.setType + st = 'FUNCTION => object2String FUNCALL(setData.setVar,"%display%") + st = 'INTEGER => object2String eval setData.setVar + st = 'STRING => object2String eval setData.setVar + st = 'LITERALS => + object2String translateTrueFalse2YesNo eval setData.setVar + st = 'TREE => '"..." + systemError() + +mkSetTitle() == STRCONC('"Command {\em )set ",listOfStrings2String $path,'"}") + +listOfStrings2String u == + null u => '"" + STRCONC(listOfStrings2String rest u,'" ",stringize first u) + +htShowSetPage(htPage, branch) == + setTree := htpProperty(htPage, 'setTree) + $path := [branch,:TAKE(- LASTATOM setTree,$path)] + setData := assoc(branch, setTree) + null setData => + systemError('"No Set Data") + st := setData.setType + st = 'FUNCTION => htShowFunctionPage(htPage, setData) + st = 'INTEGER => htShowIntegerPage(htPage,setData) + st = 'LITERALS => htShowLiteralsPage(htPage, setData) + st = 'TREE => htShowSetTree(setData.setLeaf) + + st = 'STRING => -- have to add this + htSetNotAvailable(htPage,'")set compiler") + + systemError '"Unknown data type" + +htShowLiteralsPage(htPage, setData) == + htSetLiterals(htPage,setData.setName,setData.setLabel, + setData.setVar,setData.setLeaf,'htSetLiteral) + +htSetLiterals(htPage,name,message,variable,values,functionToCall) == + page := htInitPage('"Set Command", htpPropertyList htPage) + htpSetProperty(page, 'variable, variable) + bcHt ['"\centerline{Set {\em ", name, '"}}\newline"] + bcHt ['"{\em Description: } ", message, '"\newline\vspace{1} "] + bcHt '"Select one of the following: \newline\tab{3} " + links := [[STRCONC('"",STRINGIMAGE opt), '"\newline\tab{3}", functionToCall, opt] for opt in values] + htMakePage [['bcLispLinks, :links]] + bcHt ["\indent{0}\newline\vspace{1} The current setting is: {\em ", + translateTrueFalse2YesNo EVAL variable, '"} "] + htShowPage() + +htSetLiteral(htPage, val) == + htInitPage('"Set Command", nil) + SET(htpProperty(htPage, 'variable), translateYesNo2TrueFalse val) + htKill(htPage,val) + +htShowIntegerPage(htPage, setData) == + page := htInitPage(mkSetTitle(), htpPropertyList htPage) + htpSetProperty(page, 'variable, setData.setVar) + bcHt ['"\centerline{Set {\em ", setData.setName, '"}}\newline"] +-- message := isKeyedMsgInDb($path,'(setvar text A)) or setData.setLabel + message := setData.setLabel + bcHt ['"{\em Description: } ", message, '"\newline\vspace{1} "] + [$htInitial,$htFinal] := setData.setLeaf + if $htFinal = $htInitial + 1 + then + bcHt '"Enter the integer {\em " + bcHt stringize $htInitial + bcHt '"} or {\em " + bcHt stringize $htFinal + bcHt '"}:" + else if null $htFinal then + bcHt '"Enter an integer greater than {\em " + bcHt stringize ($htInitial - 1) + bcHt '"}:" + else + bcHt '"Enter an integer between {\em " + bcHt stringize $htInitial + bcHt '"} and {\em " + bcHt stringize $htFinal + bcHt '"}:" + htMakePage [ + '(domainConditions (Satisfies S chkRange)), + ['bcStrings,[5,eval setData.setVar,'value,'S]]] + htSetvarDoneButton('"Select to Set Value",'htSetInteger) + htShowPage() + +htSetInteger(htPage) == + htInitPage(mkSetTitle(), nil) + val := chkRange htpLabelInputString(htPage,'value) + not INTEGERP val => + errorPage(htPage,['"Value Error",nil,'"\vspace{3}\centerline{{\em ",val,'"}}\vspace{2}\newline\centerline{Click on \UpBitmap{} to re-enter value}"]) + SET(htpProperty(htPage, 'variable), val) + htKill(htPage,val) + +htShowFunctionPage(htPage,setData) == + fn := setData.setDef => FUNCALL(fn,htPage) + htpSetProperty(htPage,'setData,setData) + htpSetProperty(htPage,'parts, setData.setLeaf) + htShowFunctionPageContinued(htPage) + +htShowFunctionPageContinued(htPage) == + parts := htpProperty(htPage,'parts) + setData := htpProperty(htPage,'setData) + [[phrase,kind,variable,checker,initValue,:.],:restParts] := parts + htpSetProperty(htPage, 'variable, variable) + htpSetProperty(htPage, 'checker, checker) + htpSetProperty(htPage, 'parts, restParts) + kind = 'LITERALS => htSetLiterals(htPage,setData.setName, + phrase,variable,checker,'htFunctionSetLiteral) + page := htInitPage(mkSetTitle(), htpPropertyList htPage) + bcHt ['"\centerline{Set {\em ", setData.setName, '"}}\newline"] + bcHt ['"{\em Description: } ", setData.setLabel, '"\newline\vspace{1} "] + currentValue := EVAL variable + htMakePage + [ ['domainConditions, ['Satisfies,'S,checker]], + ['text,:phrase], + ['inputStrings, + [ '"", '"", 60, currentValue, 'value, 'S]]] + htSetvarDoneButton('"Select To Set Value",'htSetFunCommand) + htShowPage() + +htSetvarDoneButton(message, func) == + bcHt '"\newline\vspace{1}\centerline{" + + if message = '"Select to Set Value" or message = '"Select to Set Values" then + bchtMakeButton('"\lisplink",'"\ControlBitmap{ClickToSet}", func) + else + bchtMakeButton('"\lisplink",CONCAT('"\fbox{", message, '"}"), func) + + bcHt '"} " + + +htFunctionSetLiteral(htPage, val) == + htInitPage('"Set Command", nil) + SET(htpProperty(htPage, 'variable), translateYesNo2TrueFalse val) + htSetFunCommandContinue(htPage,val) + +htSetFunCommand(htPage) == + variable := htpProperty(htPage,'variable) + checker := htpProperty(htPage,'checker) + value := htCheck(checker,htpLabelInputString(htPage,'value)) + SET(variable,value) --kill this later + htSetFunCommandContinue(htPage,value) + +htSetFunCommandContinue(htPage,value) == + parts := htpProperty(htPage,'parts) + continue := + null parts => false + parts is [['break,predicate],:restParts] => eval predicate + true + continue => + htpSetProperty(htPage,'parts,restParts) + htShowFunctionPageContinued(htPage) + htKill(htPage,value) + +htKill(htPage,value) == + htInitPage('"System Command", nil) + string := STRCONC('"{\em )set ",listOfStrings2String [value,:$path],'"}") + htMakePage [ + '(text + "{Here is the AXIOM system command you could have issued:}" + "\vspace{2}\newline\centerline{\tt"), + ['text,:string]] + htMakePage '((text . "}\vspace{1}\newline\rm")) + htSay '"\vspace{2}{Select \ \UpButton{} \ to go back.}" + htSay '"\newline{Select \ \ExitButton{QuitPage} \ to remove this window.}" + htProcessDoitButton ['"Press to Remove Page",'"",'htDoNothing] + htShowPage() + +htSetNotAvailable(htPage,whatToType) == + page := htInitPage('"Unavailable Set Command", htpPropertyList htPage) + htInitPage('"Unavailable System Command", nil) + string := STRCONC('"{\em ",whatToType,'"}") + htMakePage [ + '(text "\vspace{1}\newline" + "{Sorry, but this system command is not available through HyperDoc. Please directly issue this command in an AXIOM window for more information:}" + "\vspace{2}\newline\centerline{\tt"), + ['text,:string]] + htMakePage '((text . "}\vspace{1}\newline")) + htProcessDoitButton ['"Press to Remove Page",'"",'htDoNothing] + htShowPage() + +htDoNothing(htPage,command) == nil + +htCheck(checker,value) == + PAIRP checker => htCheckList(checker,parseWord value) + FUNCALL(checker,value) + +parseWord x == + STRINGP x => + and/[DIGITP x.i for i in 0..MAXINDEX x] => PARSE_-INTEGER x + INTERN x + x + +htCheckList(checker,value) == + if value in '(y ye yes Y YE YES) then value := 'yes + if value in '(n no N NO) then value := 'no + checker is [n,m] and INTEGERP n => + m = n + 1 => + value in checker => value + n + null m => + INTEGERP value and value >= n => value + n + INTEGERP m => + INTEGERP value and value >= n and value <= m => value + n + value in checker => value + first checker +-- emlist := "STRCONC"/[STRCONC('" {\em ",PNAME x,'"} ") for x in checker] +-- STRCONC('"Please enter one of: ",emlist) + +translateYesNoToTrueFalse x == + x = 'yes => true + x = 'no => false + x + +chkNameList x == + u := bcString2ListWords x + parsedNames := [ncParseFromString x for x in u] + and/[IDENTP x for x in parsedNames] => parsedNames + '"Please enter a list of identifiers separated by blanks" + +chkPosInteger s == + (u := parseOnly s) and INTEGERP u and u > 0 => u + '"Please enter a positive integer" + +chkOutputFileName s == + bcString2WordList s in '(CONSOLE console) => 'console + chkDirectory s + +chkDirectory s == s + +chkNonNegativeInteger s == + (u := ncParseFromString s) and INTEGERP u and u >= 0 => u + '"Please enter a non-negative integer" + +chkRange s == + (u := ncParseFromString s) and INTEGERP u + and u >= $htInitial and (NULL $htFinal or u <= $htFinal) + => u + null $htFinal => + STRCONC('"Please enter an integer greater than ",stringize ($htInitial - 1)) + STRCONC('"Please enter an integer between ",stringize $htInitial,'" and ", + stringize $htFinal) + +chkAllNonNegativeInteger s == + (u := ncParseFromString s) and u in '(a al all A AL ALL) and 'ALL + or chkNonNegativeInteger s + or '"Please enter {\em all} or a non-negative integer" + +htMakePathKey path == + null path => systemError '"path is not set" + INTERN fn(PNAME first path,rest path) where + fn(a,b) == + null b => a + fn(STRCONC(a,'".",PNAME first b),rest b) + +htMarkTree(tree,n) == + RPLACD(LASTTAIL tree,n) + for branch in tree repeat + branch.3 = 'TREE => htMarkTree(branch.5,n + 1) + +htSetHistory htPage == + msg := "when the history facility is on (yes), results of computations are saved in memory" + data := ['history,msg,'history,'LITERALS,'$HiFiAccess,'(on off yes no)] + htShowLiteralsPage(htPage,data) + +htSetOutputLibrary htPage == + htSetNotAvailable(htPage,'")set compiler output") + +htSetInputLibrary htPage == + htSetNotAvailable(htPage,'")set compiler input") + +htSetExpose htPage == + htSetNotAvailable(htPage,'")set expose") + +htSetKernelProtect htPage == + htSetNotAvailable(htPage,'")set kernel protect") + +htSetKernelWarn htPage == + htSetNotAvailable(htPage,'")set kernel warn") + +htSetOutputCharacters htPage == + htSetNotAvailable(htPage,'")set output characters") + +htSetLinkerArgs htPage == + htSetNotAvailable(htPage,'")set fortran calling linker") + +htSetCache(htPage,:options) == + $path := '(functions cache) + htPage := htInitPage(mkSetTitle(),nil) + $valueList := nil + htMakePage '( + (text + "Use this system command to cause the AXIOM interpreter to `remember' " + "past values of interpreter functions. " + "To remember a past value of a function, the interpreter " + "sets up a {\em cache} for that function based on argument values. " + "When a value is cached for a given argument value, its value is gotten " + "from the cache and not recomputed. Caching can often save much " + "computing time, particularly with recursive functions or functions that " + "are expensive to compute and that are called repeatedly " + "with the same argument." + "\vspace{1}\newline ") + (domainConditions (Satisfies S chkNameList)) + (text + "Enter below a list of interpreter functions you would like specially cached. " + "Use the name {\em all} to give a default setting for all " + "interpreter functions. " + "\vspace{1}\newline " + "Enter {\em all} or a list of names (separate names by blanks):") + (inputStrings ("" "" 60 "all" names S)) + (doneButton "Push to enter names" htCacheAddChoice)) + htShowPage() + +htCacheAddChoice htPage == + names := bcString2WordList htpLabelInputString(htPage,'names) + $valueList := [listOfStrings2String names,:$valueList] + null names => htCacheAddQuery() + null rest names => htCacheOne names + page := htInitPage(mkSetTitle(),nil) + htpSetProperty(page,'names,names) + htMakePage '( + (domainConditions (Satisfies ALLPI chkAllPositiveInteger)) + (text + "For each function, enter below a {\em cache length}, a positive integer. " + "This number tells how many past values will " + "be cached. " + "A cache length of {\em 0} means the function won't be cached. " + "To cache all past values, " + "enter {\em all}." + "\vspace{1}\newline " + "For each function name, enter {\em all} or a positive integer:")) + for i in 1.. for name in names repeat htMakePage [ + ['inputStrings, + [STRCONC('"Function {\em ",name,'"} will cache"), + '"values",5,10,htMakeLabel('"c",i),'ALLPI]]] + htSetvarDoneButton('"Select to Set Values",'htCacheSet) + htShowPage() + +htMakeLabel(prefix,i) == INTERN STRCONC(prefix,stringize i) + +htCacheSet htPage == + names := htpProperty(htPage,'names) + for i in 1.. for name in names repeat + num := chkAllNonNegativeInteger + htpLabelInputString(htPage,htMakeLabel('"c",i)) + $cacheAlist := ADDASSOC(INTERN name,num,$cacheAlist) + if (n := LASSOC('all,$cacheAlist)) then + $cacheCount := n + $cacheAlist := deleteAssoc('all,$cacheAlist) + htInitPage('"Cache Summary",nil) + bcHt '"In general, interpreter functions " + bcHt + $cacheCount = 0 => "will {\em not} be cached." + bcHt '"cache " + htAllOrNum $cacheCount + '"} values." + bcHt '"\vspace{1}\newline " + if $cacheAlist then +-- bcHt '" However, \indent{3}" + for [name,:val] in $cacheAlist | val ^= $cacheCount repeat + bcHt '"\newline function {\em " + bcHt stringize name + bcHt '"} will cache " + htAllOrNum val + bcHt '"} values" + htProcessDoitButton ['"Press to Remove Page",'"",'htDoNothing] + htShowPage() + +htAllOrNum val == bcHt + val = 'all => '"{\em all" + val = 0 => '"{\em no" + STRCONC('"the last {\em ",stringize val) + +htCacheOne names == + page := htInitPage(mkSetTitle(),nil) + htpSetProperty(page,'names,names) + htMakePage '( + (domainConditions (Satisfies ALLPI chkAllPositiveInteger)) + (text + "Enter below a {\em cache length}, a positive integer. " + "This number tells how many past values will " + "be cached. To cache all past values, " + "enter {\em all}." + "\vspace{1}\newline ") + (inputStrings + ("Enter {\em all} or a positive integer:" + "" 5 10 c1 ALLPI))) + htSetvarDoneButton('"Select to Set Value",'htCacheSet) + htShowPage() + + + + + + + + diff --git a/src/interp/htsetvar.boot.pamphlet b/src/interp/htsetvar.boot.pamphlet deleted file mode 100644 index f1b38f7d..00000000 --- a/src/interp/htsetvar.boot.pamphlet +++ /dev/null @@ -1,503 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp htsetvar.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\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. - -@ -<<*>>= -<> - -import '"macros" -)package "BOOT" - -htsv() == - startHTPage(50) - htSetVars() - -htSetVars() == - $path := nil - $lastTree := nil - if 0 ^= LASTATOM $setOptions then htMarkTree($setOptions,0) - htShowSetTree($setOptions) - -htShowSetTree(setTree) == - $path := TAKE(- LASTATOM setTree,$path) - page := htInitPage(mkSetTitle(),nil) - htpSetProperty(page, 'setTree, setTree) - links := nil - maxWidth1 := maxWidth2 := 0 - for setData in setTree repeat - satisfiesUserLevel setData.setLevel => - okList := [setData,:okList] - maxWidth1 := MAX(# PNAME setData.setName,maxWidth1) - maxWidth2 := MAX(htShowCount STRINGIMAGE setData.setLabel,maxWidth2) - maxWidth1 := MAX(9,maxWidth1) - maxWidth2 := MAX(41,maxWidth2) - tabset1 := STRINGIMAGE (maxWidth1) - tabset2 := STRINGIMAGE (maxWidth2 + maxWidth1 - 1) - htSay('"\tab{2}\newline Variable\tab{",STRINGIMAGE (maxWidth1 + (maxWidth2/3)),'"}Description\tab{",STRINGIMAGE(maxWidth2 + maxWidth1 + 2),'"}Value\newline\beginitems ") - for setData in REVERSE okList repeat - htSay '"\item" - label := STRCONC('"\menuitemstyle{",setData.setName,'"}") - links := [label,[['text,'"\tab{",tabset1,'"}",setData.setLabel,'"\tab{",tabset2,'"}{\em ",htShowSetTreeValue setData,'"}"]], - 'htShowSetPage, setData.setName] - htMakePage [['bcLispLinks, links,'options,'(indent . 0)]] - htSay '"\enditems" - htShowPage() - -htShowCount s == --# discounting {\em .. } - m := #s - m < 8 => m - 1 - i := 0 - count := 0 - while i < m - 7 repeat - s.i = char '_{ and s.(i+1) = char '_\ and s.(i+2) = char 'e - and s.(i+3) = char 'm => i := i + 6 --discount {\em } - i := i + 1 - count := count + 1 - count + (m - i) - -htShowSetTreeValue(setData) == - st := setData.setType - st = 'FUNCTION => object2String FUNCALL(setData.setVar,"%display%") - st = 'INTEGER => object2String eval setData.setVar - st = 'STRING => object2String eval setData.setVar - st = 'LITERALS => - object2String translateTrueFalse2YesNo eval setData.setVar - st = 'TREE => '"..." - systemError() - -mkSetTitle() == STRCONC('"Command {\em )set ",listOfStrings2String $path,'"}") - -listOfStrings2String u == - null u => '"" - STRCONC(listOfStrings2String rest u,'" ",stringize first u) - -htShowSetPage(htPage, branch) == - setTree := htpProperty(htPage, 'setTree) - $path := [branch,:TAKE(- LASTATOM setTree,$path)] - setData := assoc(branch, setTree) - null setData => - systemError('"No Set Data") - st := setData.setType - st = 'FUNCTION => htShowFunctionPage(htPage, setData) - st = 'INTEGER => htShowIntegerPage(htPage,setData) - st = 'LITERALS => htShowLiteralsPage(htPage, setData) - st = 'TREE => htShowSetTree(setData.setLeaf) - - st = 'STRING => -- have to add this - htSetNotAvailable(htPage,'")set compiler") - - systemError '"Unknown data type" - -htShowLiteralsPage(htPage, setData) == - htSetLiterals(htPage,setData.setName,setData.setLabel, - setData.setVar,setData.setLeaf,'htSetLiteral) - -htSetLiterals(htPage,name,message,variable,values,functionToCall) == - page := htInitPage('"Set Command", htpPropertyList htPage) - htpSetProperty(page, 'variable, variable) - bcHt ['"\centerline{Set {\em ", name, '"}}\newline"] - bcHt ['"{\em Description: } ", message, '"\newline\vspace{1} "] - bcHt '"Select one of the following: \newline\tab{3} " - links := [[STRCONC('"",STRINGIMAGE opt), '"\newline\tab{3}", functionToCall, opt] for opt in values] - htMakePage [['bcLispLinks, :links]] - bcHt ["\indent{0}\newline\vspace{1} The current setting is: {\em ", - translateTrueFalse2YesNo EVAL variable, '"} "] - htShowPage() - -htSetLiteral(htPage, val) == - htInitPage('"Set Command", nil) - SET(htpProperty(htPage, 'variable), translateYesNo2TrueFalse val) - htKill(htPage,val) - -htShowIntegerPage(htPage, setData) == - page := htInitPage(mkSetTitle(), htpPropertyList htPage) - htpSetProperty(page, 'variable, setData.setVar) - bcHt ['"\centerline{Set {\em ", setData.setName, '"}}\newline"] --- message := isKeyedMsgInDb($path,'(setvar text A)) or setData.setLabel - message := setData.setLabel - bcHt ['"{\em Description: } ", message, '"\newline\vspace{1} "] - [$htInitial,$htFinal] := setData.setLeaf - if $htFinal = $htInitial + 1 - then - bcHt '"Enter the integer {\em " - bcHt stringize $htInitial - bcHt '"} or {\em " - bcHt stringize $htFinal - bcHt '"}:" - else if null $htFinal then - bcHt '"Enter an integer greater than {\em " - bcHt stringize ($htInitial - 1) - bcHt '"}:" - else - bcHt '"Enter an integer between {\em " - bcHt stringize $htInitial - bcHt '"} and {\em " - bcHt stringize $htFinal - bcHt '"}:" - htMakePage [ - '(domainConditions (Satisfies S chkRange)), - ['bcStrings,[5,eval setData.setVar,'value,'S]]] - htSetvarDoneButton('"Select to Set Value",'htSetInteger) - htShowPage() - -htSetInteger(htPage) == - htInitPage(mkSetTitle(), nil) - val := chkRange htpLabelInputString(htPage,'value) - not INTEGERP val => - errorPage(htPage,['"Value Error",nil,'"\vspace{3}\centerline{{\em ",val,'"}}\vspace{2}\newline\centerline{Click on \UpBitmap{} to re-enter value}"]) - SET(htpProperty(htPage, 'variable), val) - htKill(htPage,val) - -htShowFunctionPage(htPage,setData) == - fn := setData.setDef => FUNCALL(fn,htPage) - htpSetProperty(htPage,'setData,setData) - htpSetProperty(htPage,'parts, setData.setLeaf) - htShowFunctionPageContinued(htPage) - -htShowFunctionPageContinued(htPage) == - parts := htpProperty(htPage,'parts) - setData := htpProperty(htPage,'setData) - [[phrase,kind,variable,checker,initValue,:.],:restParts] := parts - htpSetProperty(htPage, 'variable, variable) - htpSetProperty(htPage, 'checker, checker) - htpSetProperty(htPage, 'parts, restParts) - kind = 'LITERALS => htSetLiterals(htPage,setData.setName, - phrase,variable,checker,'htFunctionSetLiteral) - page := htInitPage(mkSetTitle(), htpPropertyList htPage) - bcHt ['"\centerline{Set {\em ", setData.setName, '"}}\newline"] - bcHt ['"{\em Description: } ", setData.setLabel, '"\newline\vspace{1} "] - currentValue := EVAL variable - htMakePage - [ ['domainConditions, ['Satisfies,'S,checker]], - ['text,:phrase], - ['inputStrings, - [ '"", '"", 60, currentValue, 'value, 'S]]] - htSetvarDoneButton('"Select To Set Value",'htSetFunCommand) - htShowPage() - -htSetvarDoneButton(message, func) == - bcHt '"\newline\vspace{1}\centerline{" - - if message = '"Select to Set Value" or message = '"Select to Set Values" then - bchtMakeButton('"\lisplink",'"\ControlBitmap{ClickToSet}", func) - else - bchtMakeButton('"\lisplink",CONCAT('"\fbox{", message, '"}"), func) - - bcHt '"} " - - -htFunctionSetLiteral(htPage, val) == - htInitPage('"Set Command", nil) - SET(htpProperty(htPage, 'variable), translateYesNo2TrueFalse val) - htSetFunCommandContinue(htPage,val) - -htSetFunCommand(htPage) == - variable := htpProperty(htPage,'variable) - checker := htpProperty(htPage,'checker) - value := htCheck(checker,htpLabelInputString(htPage,'value)) - SET(variable,value) --kill this later - htSetFunCommandContinue(htPage,value) - -htSetFunCommandContinue(htPage,value) == - parts := htpProperty(htPage,'parts) - continue := - null parts => false - parts is [['break,predicate],:restParts] => eval predicate - true - continue => - htpSetProperty(htPage,'parts,restParts) - htShowFunctionPageContinued(htPage) - htKill(htPage,value) - -htKill(htPage,value) == - htInitPage('"System Command", nil) - string := STRCONC('"{\em )set ",listOfStrings2String [value,:$path],'"}") - htMakePage [ - '(text - "{Here is the AXIOM system command you could have issued:}" - "\vspace{2}\newline\centerline{\tt"), - ['text,:string]] - htMakePage '((text . "}\vspace{1}\newline\rm")) - htSay '"\vspace{2}{Select \ \UpButton{} \ to go back.}" - htSay '"\newline{Select \ \ExitButton{QuitPage} \ to remove this window.}" - htProcessDoitButton ['"Press to Remove Page",'"",'htDoNothing] - htShowPage() - -htSetNotAvailable(htPage,whatToType) == - page := htInitPage('"Unavailable Set Command", htpPropertyList htPage) - htInitPage('"Unavailable System Command", nil) - string := STRCONC('"{\em ",whatToType,'"}") - htMakePage [ - '(text "\vspace{1}\newline" - "{Sorry, but this system command is not available through HyperDoc. Please directly issue this command in an AXIOM window for more information:}" - "\vspace{2}\newline\centerline{\tt"), - ['text,:string]] - htMakePage '((text . "}\vspace{1}\newline")) - htProcessDoitButton ['"Press to Remove Page",'"",'htDoNothing] - htShowPage() - -htDoNothing(htPage,command) == nil - -htCheck(checker,value) == - PAIRP checker => htCheckList(checker,parseWord value) - FUNCALL(checker,value) - -parseWord x == - STRINGP x => - and/[DIGITP x.i for i in 0..MAXINDEX x] => PARSE_-INTEGER x - INTERN x - x - -htCheckList(checker,value) == - if value in '(y ye yes Y YE YES) then value := 'yes - if value in '(n no N NO) then value := 'no - checker is [n,m] and INTEGERP n => - m = n + 1 => - value in checker => value - n - null m => - INTEGERP value and value >= n => value - n - INTEGERP m => - INTEGERP value and value >= n and value <= m => value - n - value in checker => value - first checker --- emlist := "STRCONC"/[STRCONC('" {\em ",PNAME x,'"} ") for x in checker] --- STRCONC('"Please enter one of: ",emlist) - -translateYesNoToTrueFalse x == - x = 'yes => true - x = 'no => false - x - -chkNameList x == - u := bcString2ListWords x - parsedNames := [ncParseFromString x for x in u] - and/[IDENTP x for x in parsedNames] => parsedNames - '"Please enter a list of identifiers separated by blanks" - -chkPosInteger s == - (u := parseOnly s) and INTEGERP u and u > 0 => u - '"Please enter a positive integer" - -chkOutputFileName s == - bcString2WordList s in '(CONSOLE console) => 'console - chkDirectory s - -chkDirectory s == s - -chkNonNegativeInteger s == - (u := ncParseFromString s) and INTEGERP u and u >= 0 => u - '"Please enter a non-negative integer" - -chkRange s == - (u := ncParseFromString s) and INTEGERP u - and u >= $htInitial and (NULL $htFinal or u <= $htFinal) - => u - null $htFinal => - STRCONC('"Please enter an integer greater than ",stringize ($htInitial - 1)) - STRCONC('"Please enter an integer between ",stringize $htInitial,'" and ", - stringize $htFinal) - -chkAllNonNegativeInteger s == - (u := ncParseFromString s) and u in '(a al all A AL ALL) and 'ALL - or chkNonNegativeInteger s - or '"Please enter {\em all} or a non-negative integer" - -htMakePathKey path == - null path => systemError '"path is not set" - INTERN fn(PNAME first path,rest path) where - fn(a,b) == - null b => a - fn(STRCONC(a,'".",PNAME first b),rest b) - -htMarkTree(tree,n) == - RPLACD(LASTTAIL tree,n) - for branch in tree repeat - branch.3 = 'TREE => htMarkTree(branch.5,n + 1) - -htSetHistory htPage == - msg := "when the history facility is on (yes), results of computations are saved in memory" - data := ['history,msg,'history,'LITERALS,'$HiFiAccess,'(on off yes no)] - htShowLiteralsPage(htPage,data) - -htSetOutputLibrary htPage == - htSetNotAvailable(htPage,'")set compiler output") - -htSetInputLibrary htPage == - htSetNotAvailable(htPage,'")set compiler input") - -htSetExpose htPage == - htSetNotAvailable(htPage,'")set expose") - -htSetKernelProtect htPage == - htSetNotAvailable(htPage,'")set kernel protect") - -htSetKernelWarn htPage == - htSetNotAvailable(htPage,'")set kernel warn") - -htSetOutputCharacters htPage == - htSetNotAvailable(htPage,'")set output characters") - -htSetLinkerArgs htPage == - htSetNotAvailable(htPage,'")set fortran calling linker") - -htSetCache(htPage,:options) == - $path := '(functions cache) - htPage := htInitPage(mkSetTitle(),nil) - $valueList := nil - htMakePage '( - (text - "Use this system command to cause the AXIOM interpreter to `remember' " - "past values of interpreter functions. " - "To remember a past value of a function, the interpreter " - "sets up a {\em cache} for that function based on argument values. " - "When a value is cached for a given argument value, its value is gotten " - "from the cache and not recomputed. Caching can often save much " - "computing time, particularly with recursive functions or functions that " - "are expensive to compute and that are called repeatedly " - "with the same argument." - "\vspace{1}\newline ") - (domainConditions (Satisfies S chkNameList)) - (text - "Enter below a list of interpreter functions you would like specially cached. " - "Use the name {\em all} to give a default setting for all " - "interpreter functions. " - "\vspace{1}\newline " - "Enter {\em all} or a list of names (separate names by blanks):") - (inputStrings ("" "" 60 "all" names S)) - (doneButton "Push to enter names" htCacheAddChoice)) - htShowPage() - -htCacheAddChoice htPage == - names := bcString2WordList htpLabelInputString(htPage,'names) - $valueList := [listOfStrings2String names,:$valueList] - null names => htCacheAddQuery() - null rest names => htCacheOne names - page := htInitPage(mkSetTitle(),nil) - htpSetProperty(page,'names,names) - htMakePage '( - (domainConditions (Satisfies ALLPI chkAllPositiveInteger)) - (text - "For each function, enter below a {\em cache length}, a positive integer. " - "This number tells how many past values will " - "be cached. " - "A cache length of {\em 0} means the function won't be cached. " - "To cache all past values, " - "enter {\em all}." - "\vspace{1}\newline " - "For each function name, enter {\em all} or a positive integer:")) - for i in 1.. for name in names repeat htMakePage [ - ['inputStrings, - [STRCONC('"Function {\em ",name,'"} will cache"), - '"values",5,10,htMakeLabel('"c",i),'ALLPI]]] - htSetvarDoneButton('"Select to Set Values",'htCacheSet) - htShowPage() - -htMakeLabel(prefix,i) == INTERN STRCONC(prefix,stringize i) - -htCacheSet htPage == - names := htpProperty(htPage,'names) - for i in 1.. for name in names repeat - num := chkAllNonNegativeInteger - htpLabelInputString(htPage,htMakeLabel('"c",i)) - $cacheAlist := ADDASSOC(INTERN name,num,$cacheAlist) - if (n := LASSOC('all,$cacheAlist)) then - $cacheCount := n - $cacheAlist := deleteAssoc('all,$cacheAlist) - htInitPage('"Cache Summary",nil) - bcHt '"In general, interpreter functions " - bcHt - $cacheCount = 0 => "will {\em not} be cached." - bcHt '"cache " - htAllOrNum $cacheCount - '"} values." - bcHt '"\vspace{1}\newline " - if $cacheAlist then --- bcHt '" However, \indent{3}" - for [name,:val] in $cacheAlist | val ^= $cacheCount repeat - bcHt '"\newline function {\em " - bcHt stringize name - bcHt '"} will cache " - htAllOrNum val - bcHt '"} values" - htProcessDoitButton ['"Press to Remove Page",'"",'htDoNothing] - htShowPage() - -htAllOrNum val == bcHt - val = 'all => '"{\em all" - val = 0 => '"{\em no" - STRCONC('"the last {\em ",stringize val) - -htCacheOne names == - page := htInitPage(mkSetTitle(),nil) - htpSetProperty(page,'names,names) - htMakePage '( - (domainConditions (Satisfies ALLPI chkAllPositiveInteger)) - (text - "Enter below a {\em cache length}, a positive integer. " - "This number tells how many past values will " - "be cached. To cache all past values, " - "enter {\em all}." - "\vspace{1}\newline ") - (inputStrings - ("Enter {\em all} or a positive integer:" - "" 5 10 c1 ALLPI))) - htSetvarDoneButton('"Select to Set Value",'htCacheSet) - htShowPage() - - - - - - - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/hypertex.boot b/src/interp/hypertex.boot new file mode 100644 index 00000000..21a3a1e3 --- /dev/null +++ b/src/interp/hypertex.boot @@ -0,0 +1,125 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- 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. + + +import '"boot-pkg" +)package "BOOT" + +-- HyperTex Spad interface + +-- SETANDFILEQ($SendXEventToHyperTeX, 8) +$LinkToPage == 96 +$StartPage == 97 +$SendLine == 98 +$EndOfPage == 99 +$PopUpPage == 95 +$PopUpNamedPage == 94 +$KillPage == 93 +$ReplacePage == 92 +$ReplaceNamedPage == 91 +$SpadError == 90 +$PageStuff == 100 + + + +-- Issue a line of HyperTex +issueHT line == +-- unescapeStringsInForm line + sockSendInt($MenuServer, $SendLine) + sockSendString($MenuServer, line) + +endHTPage() == + sockSendInt($MenuServer, $EndOfPage) + +testPage() == + startHTPage(50) + issueHT '"\page{TestPage}{Test Page generated from Lisp} " + issueHT '"\horizontalline\beginscroll\beginitems " + issueHT '"\item \downlink{Quayle Jokes}{ChickenPage} \space{2} " + issueHT '"The misadventures of the White House bellboy. " + issueHT '"\enditems\endscroll\autobuttons " + endHTPage() + +-- Replace a current hypertex page +replaceNamedHTPage(window, name) == + sockSendInt($MenuServer, $PageStuff) + sockSendInt($MenuServer, $currentFrameNum) + sockSendInt($MenuServer, $ReplaceNamedPage) + sockSendInt($MenuServer, window) + sockSendString($MenuServer, name) + +-- Start up a form page from spad +startHTPopUpPage cols == + sockSendInt($MenuServer, $PageStuff) + sockSendInt($MenuServer, $currentFrameNum) + sockSendInt($MenuServer, $PopUpPage) + sockSendInt($MenuServer, cols) + sockGetInt($MenuServer) + +-- Start a page from spad. Using the spcified number of columns +startHTPage cols == + sockSendInt($MenuServer, $PageStuff) + sockSendInt($MenuServer, $currentFrameNum) + sockSendInt($MenuServer, $StartPage) + sockSendInt($MenuServer, cols) + +-- Start a replace page sequence +startReplaceHTPage w == + sockSendInt($MenuServer, $PageStuff) + sockSendInt($MenuServer, $currentFrameNum) + sockSendInt($MenuServer, $ReplacePage) + sockSendInt($MenuServer, w) + +-- Kill a page feom scratchpad +killHTPage w == + sockSendInt($MenuServer, $PageStuff) + sockSendInt($MenuServer, $currentFrameNum) + sockSendInt($MenuServer, $KillPage) + sockSendInt($MenuServer, w) + +linkToHTPage name == + sockSendInt($MenuServer, $PageStuff) + sockSendInt($MenuServer, $currentFrameNum) + sockSendInt($MenuServer, $LinkToPage) + sockSendString($MenuServer, name) + +popUpNamedHTPage(name,cols) == + sockSendInt($MenuServer, $PageStuff) + sockSendInt($MenuServer, $currentFrameNum) + sockSendInt($MenuServer, $PopUpNamedPage) + sockSendInt($MenuServer, cols) + sockSendString($MenuServer, name) + sockGetInt($MenuServer) + +sendHTErrorSignal() == + sockSendInt($MenuServer, $SpadError) diff --git a/src/interp/hypertex.boot.pamphlet b/src/interp/hypertex.boot.pamphlet deleted file mode 100644 index 208f8aa7..00000000 --- a/src/interp/hypertex.boot.pamphlet +++ /dev/null @@ -1,145 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp hypertex.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\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. - -@ -<<*>>= -<> - -import '"boot-pkg" -)package "BOOT" - --- HyperTex Spad interface - --- SETANDFILEQ($SendXEventToHyperTeX, 8) -$LinkToPage == 96 -$StartPage == 97 -$SendLine == 98 -$EndOfPage == 99 -$PopUpPage == 95 -$PopUpNamedPage == 94 -$KillPage == 93 -$ReplacePage == 92 -$ReplaceNamedPage == 91 -$SpadError == 90 -$PageStuff == 100 - - - --- Issue a line of HyperTex -issueHT line == --- unescapeStringsInForm line - sockSendInt($MenuServer, $SendLine) - sockSendString($MenuServer, line) - -endHTPage() == - sockSendInt($MenuServer, $EndOfPage) - -testPage() == - startHTPage(50) - issueHT '"\page{TestPage}{Test Page generated from Lisp} " - issueHT '"\horizontalline\beginscroll\beginitems " - issueHT '"\item \downlink{Quayle Jokes}{ChickenPage} \space{2} " - issueHT '"The misadventures of the White House bellboy. " - issueHT '"\enditems\endscroll\autobuttons " - endHTPage() - --- Replace a current hypertex page -replaceNamedHTPage(window, name) == - sockSendInt($MenuServer, $PageStuff) - sockSendInt($MenuServer, $currentFrameNum) - sockSendInt($MenuServer, $ReplaceNamedPage) - sockSendInt($MenuServer, window) - sockSendString($MenuServer, name) - --- Start up a form page from spad -startHTPopUpPage cols == - sockSendInt($MenuServer, $PageStuff) - sockSendInt($MenuServer, $currentFrameNum) - sockSendInt($MenuServer, $PopUpPage) - sockSendInt($MenuServer, cols) - sockGetInt($MenuServer) - --- Start a page from spad. Using the spcified number of columns -startHTPage cols == - sockSendInt($MenuServer, $PageStuff) - sockSendInt($MenuServer, $currentFrameNum) - sockSendInt($MenuServer, $StartPage) - sockSendInt($MenuServer, cols) - --- Start a replace page sequence -startReplaceHTPage w == - sockSendInt($MenuServer, $PageStuff) - sockSendInt($MenuServer, $currentFrameNum) - sockSendInt($MenuServer, $ReplacePage) - sockSendInt($MenuServer, w) - --- Kill a page feom scratchpad -killHTPage w == - sockSendInt($MenuServer, $PageStuff) - sockSendInt($MenuServer, $currentFrameNum) - sockSendInt($MenuServer, $KillPage) - sockSendInt($MenuServer, w) - -linkToHTPage name == - sockSendInt($MenuServer, $PageStuff) - sockSendInt($MenuServer, $currentFrameNum) - sockSendInt($MenuServer, $LinkToPage) - sockSendString($MenuServer, name) - -popUpNamedHTPage(name,cols) == - sockSendInt($MenuServer, $PageStuff) - sockSendInt($MenuServer, $currentFrameNum) - sockSendInt($MenuServer, $PopUpNamedPage) - sockSendInt($MenuServer, cols) - sockSendString($MenuServer, name) - sockGetInt($MenuServer) - -sendHTErrorSignal() == - sockSendInt($MenuServer, $SpadError) -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/macex.boot b/src/interp/macex.boot new file mode 100644 index 00000000..b15445e0 --- /dev/null +++ b/src/interp/macex.boot @@ -0,0 +1,191 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- 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" + +--% Macro expansion +-- Functions to transform parse forms. +-- +-- Global variables: +-- $pfMacros is an alist [[id, state, body-pform], ...] +-- (set in newcompInit). +-- state is one of: mbody, mparam, mlambda +-- +-- $macActive is a list of the bodies being expanded. +-- $posActive is a list of the parse forms where the bodies came from. + +-- Beware: the name macroExpand is used by the old compiler. +macroExpanded pf == + $macActive: local := [] + $posActive: local := [] + + macExpand pf + +macExpand pf == + pfWhere? pf => macWhere pf + pfLambda? pf => macLambda pf + pfMacro? pf => macMacro pf + + pfId? pf => macId pf + pfApplication? pf => macApplication pf + pfMapParts(function macExpand, pf) + +macWhere pf == + mac(pf,$pfMacros) where + mac(pf,$pfMacros) == + -- pfWhereContext is before pfWhereExpr + pfMapParts(function macExpand, pf) + +macLambda pf == + mac(pf,$pfMacros) where + mac(pf,$pfMacros) == + pfMapParts(function macExpand, pf) + +macLambdaParameterHandling( replist , pform ) == + pfLeaf? pform => [] + pfLambda? pform => -- remove ( identifier . replacement ) from assoclist + parlist := [ pfTypedId p for p in pf0LambdaArgs pform ] -- extract parameters + for par in [ pfIdSymbol par for par in parlist ] repeat + replist := AlistRemoveQ(par,replist) + replist + pfMLambda? pform => -- construct assoclist ( identifier . replacement ) + parlist := pf0MLambdaArgs pform -- extract parameter list + [[pfIdSymbol par ,:pfLeaf( pfAbSynOp par,GENSYM(),pfLeafPosition par)] for par in parlist ] + for p in pfParts pform repeat macLambdaParameterHandling( replist , p ) + +macSubstituteId( replist , pform ) == + ex := AlistAssocQ( pfIdSymbol pform , replist ) + ex => + RPLPAIR(pform,CDR ex) + pform + pform + +macSubstituteOuter( pform ) == + mac0SubstituteOuter( macLambdaParameterHandling( [] , pform ) , pform ) + +mac0SubstituteOuter( replist , pform ) == + pfId? pform => macSubstituteId( replist , pform ) + pfLeaf? pform => pform + pfLambda? pform => + tmplist := macLambdaParameterHandling( replist , pform ) + for p in pfParts pform repeat mac0SubstituteOuter( tmplist , p ) + pform + for p in pfParts pform repeat mac0SubstituteOuter( replist , p ) + pform + +-- This function adds the appropriate definition and returns +-- the original Macro pform. +macMacro pf == + lhs := pfMacroLhs pf + rhs := pfMacroRhs pf + not pfId? lhs => + ncSoftError (pfSourcePosition lhs, 'S2CM0001, [%pform lhs] ) + pf + sy := pfIdSymbol lhs + + mac0Define(sy, if pfMLambda? rhs then 'mlambda else 'mbody, macSubstituteOuter rhs) + + if pfNothing? rhs then pf else pfMacro(lhs, pfNothing()) + +mac0Define(sy, state, body) == + $pfMacros := cons([sy, state, body], $pfMacros) + +-- Returns [state, body] or NIL. +mac0Get sy == + IFCDR ASSOC(sy, $pfMacros) + +-- Returns [sy, state] or NIL. +mac0GetName body == + name := nil + for [sy,st,bd] in $pfMacros while not name repeat + if st = 'mlambda then + bd := pfMLambdaBody bd + EQ(bd, body) => name := [sy,st] + name + +macId pf == + sy := pfIdSymbol pf + not (got := mac0Get sy) => pf + [state, body] := got + + state = 'mparam => body -- expanded already + state = 'mlambda => pfCopyWithPos( body , pfSourcePosition pf ) -- expanded later + + pfCopyWithPos( mac0ExpandBody(body, pf, $macActive, $posActive) , pfSourcePosition pf ) + +macApplication pf == + pf := pfMapParts(function macExpand, pf) + + op := pfApplicationOp pf + not pfMLambda? op => pf + + args := pf0ApplicationArgs pf + mac0MLambdaApply(op, args, pf, $pfMacros) + +mac0MLambdaApply(mlambda, args, opf, $pfMacros) == + params := pf0MLambdaArgs mlambda + body := pfMLambdaBody mlambda + #args ^= #params => + pos := pfSourcePosition opf + ncHardError(pos,'S2CM0003, [#params,#args]) + for p in params for a in args repeat + not pfId? p => + pos := pfSourcePosition opf + ncHardError(pos, 'S2CM0004, [%pform p]) + mac0Define(pfIdSymbol p, 'mparam, a) + + mac0ExpandBody( body , opf, $macActive, $posActive) + +mac0ExpandBody(body, opf, $macActive, $posActive) == + MEMQ(body,$macActive) => + [.,pf] := $posActive + posn := pfSourcePosition pf + mac0InfiniteExpansion(posn, body, $macActive) + $macActive := [body, :$macActive] + $posActive := [opf, :$posActive] + macExpand body + +mac0InfiniteExpansion(posn, body, active) == + blist := [body, :active] + [fname, :rnames] := [name b for b in blist] where + name b == + got := mac0GetName b + not got => '"???" + [sy,st] := got + st = 'mlambda => CONCAT(PNAME sy, '"(...)") + PNAME sy + ncSoftError (posn, 'S2CM0005, _ + [ [:[n,'"==>"] for n in reverse rnames], fname, %pform body ] ) + + body diff --git a/src/interp/macex.boot.pamphlet b/src/interp/macex.boot.pamphlet deleted file mode 100644 index a275c59b..00000000 --- a/src/interp/macex.boot.pamphlet +++ /dev/null @@ -1,211 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp macex.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\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" - ---% Macro expansion --- Functions to transform parse forms. --- --- Global variables: --- $pfMacros is an alist [[id, state, body-pform], ...] --- (set in newcompInit). --- state is one of: mbody, mparam, mlambda --- --- $macActive is a list of the bodies being expanded. --- $posActive is a list of the parse forms where the bodies came from. - --- Beware: the name macroExpand is used by the old compiler. -macroExpanded pf == - $macActive: local := [] - $posActive: local := [] - - macExpand pf - -macExpand pf == - pfWhere? pf => macWhere pf - pfLambda? pf => macLambda pf - pfMacro? pf => macMacro pf - - pfId? pf => macId pf - pfApplication? pf => macApplication pf - pfMapParts(function macExpand, pf) - -macWhere pf == - mac(pf,$pfMacros) where - mac(pf,$pfMacros) == - -- pfWhereContext is before pfWhereExpr - pfMapParts(function macExpand, pf) - -macLambda pf == - mac(pf,$pfMacros) where - mac(pf,$pfMacros) == - pfMapParts(function macExpand, pf) - -macLambdaParameterHandling( replist , pform ) == - pfLeaf? pform => [] - pfLambda? pform => -- remove ( identifier . replacement ) from assoclist - parlist := [ pfTypedId p for p in pf0LambdaArgs pform ] -- extract parameters - for par in [ pfIdSymbol par for par in parlist ] repeat - replist := AlistRemoveQ(par,replist) - replist - pfMLambda? pform => -- construct assoclist ( identifier . replacement ) - parlist := pf0MLambdaArgs pform -- extract parameter list - [[pfIdSymbol par ,:pfLeaf( pfAbSynOp par,GENSYM(),pfLeafPosition par)] for par in parlist ] - for p in pfParts pform repeat macLambdaParameterHandling( replist , p ) - -macSubstituteId( replist , pform ) == - ex := AlistAssocQ( pfIdSymbol pform , replist ) - ex => - RPLPAIR(pform,CDR ex) - pform - pform - -macSubstituteOuter( pform ) == - mac0SubstituteOuter( macLambdaParameterHandling( [] , pform ) , pform ) - -mac0SubstituteOuter( replist , pform ) == - pfId? pform => macSubstituteId( replist , pform ) - pfLeaf? pform => pform - pfLambda? pform => - tmplist := macLambdaParameterHandling( replist , pform ) - for p in pfParts pform repeat mac0SubstituteOuter( tmplist , p ) - pform - for p in pfParts pform repeat mac0SubstituteOuter( replist , p ) - pform - --- This function adds the appropriate definition and returns --- the original Macro pform. -macMacro pf == - lhs := pfMacroLhs pf - rhs := pfMacroRhs pf - not pfId? lhs => - ncSoftError (pfSourcePosition lhs, 'S2CM0001, [%pform lhs] ) - pf - sy := pfIdSymbol lhs - - mac0Define(sy, if pfMLambda? rhs then 'mlambda else 'mbody, macSubstituteOuter rhs) - - if pfNothing? rhs then pf else pfMacro(lhs, pfNothing()) - -mac0Define(sy, state, body) == - $pfMacros := cons([sy, state, body], $pfMacros) - --- Returns [state, body] or NIL. -mac0Get sy == - IFCDR ASSOC(sy, $pfMacros) - --- Returns [sy, state] or NIL. -mac0GetName body == - name := nil - for [sy,st,bd] in $pfMacros while not name repeat - if st = 'mlambda then - bd := pfMLambdaBody bd - EQ(bd, body) => name := [sy,st] - name - -macId pf == - sy := pfIdSymbol pf - not (got := mac0Get sy) => pf - [state, body] := got - - state = 'mparam => body -- expanded already - state = 'mlambda => pfCopyWithPos( body , pfSourcePosition pf ) -- expanded later - - pfCopyWithPos( mac0ExpandBody(body, pf, $macActive, $posActive) , pfSourcePosition pf ) - -macApplication pf == - pf := pfMapParts(function macExpand, pf) - - op := pfApplicationOp pf - not pfMLambda? op => pf - - args := pf0ApplicationArgs pf - mac0MLambdaApply(op, args, pf, $pfMacros) - -mac0MLambdaApply(mlambda, args, opf, $pfMacros) == - params := pf0MLambdaArgs mlambda - body := pfMLambdaBody mlambda - #args ^= #params => - pos := pfSourcePosition opf - ncHardError(pos,'S2CM0003, [#params,#args]) - for p in params for a in args repeat - not pfId? p => - pos := pfSourcePosition opf - ncHardError(pos, 'S2CM0004, [%pform p]) - mac0Define(pfIdSymbol p, 'mparam, a) - - mac0ExpandBody( body , opf, $macActive, $posActive) - -mac0ExpandBody(body, opf, $macActive, $posActive) == - MEMQ(body,$macActive) => - [.,pf] := $posActive - posn := pfSourcePosition pf - mac0InfiniteExpansion(posn, body, $macActive) - $macActive := [body, :$macActive] - $posActive := [opf, :$posActive] - macExpand body - -mac0InfiniteExpansion(posn, body, active) == - blist := [body, :active] - [fname, :rnames] := [name b for b in blist] where - name b == - got := mac0GetName b - not got => '"???" - [sy,st] := got - st = 'mlambda => CONCAT(PNAME sy, '"(...)") - PNAME sy - ncSoftError (posn, 'S2CM0005, _ - [ [:[n,'"==>"] for n in reverse rnames], fname, %pform body ] ) - - body -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/nag-c02.boot b/src/interp/nag-c02.boot index a7cf81f6..2eade7ba 100644 --- a/src/interp/nag-c02.boot +++ b/src/interp/nag-c02.boot @@ -1,5 +1,7 @@ -- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are diff --git a/src/interp/nag-c05.boot b/src/interp/nag-c05.boot index 80436694..82d7c981 100644 --- a/src/interp/nag-c05.boot +++ b/src/interp/nag-c05.boot @@ -1,5 +1,7 @@ -- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are diff --git a/src/interp/nag-c06.boot b/src/interp/nag-c06.boot index f5733a6a..a61f5d42 100644 --- a/src/interp/nag-c06.boot +++ b/src/interp/nag-c06.boot @@ -1,5 +1,7 @@ -- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are diff --git a/src/interp/nag-d01.boot b/src/interp/nag-d01.boot index 9d85ecff..3d1ea138 100644 --- a/src/interp/nag-d01.boot +++ b/src/interp/nag-d01.boot @@ -1,5 +1,7 @@ -- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are diff --git a/src/interp/nag-d02.boot b/src/interp/nag-d02.boot index 69510bac..3387f5f7 100644 --- a/src/interp/nag-d02.boot +++ b/src/interp/nag-d02.boot @@ -1,5 +1,7 @@ -- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are diff --git a/src/interp/nag-d03.boot b/src/interp/nag-d03.boot index 912d8cea..17a6f86f 100644 --- a/src/interp/nag-d03.boot +++ b/src/interp/nag-d03.boot @@ -1,5 +1,7 @@ -- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are diff --git a/src/interp/nag-e01.boot b/src/interp/nag-e01.boot index 51e56996..a5d7df0c 100644 --- a/src/interp/nag-e01.boot +++ b/src/interp/nag-e01.boot @@ -1,5 +1,7 @@ -- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are diff --git a/src/interp/nag-e02.boot b/src/interp/nag-e02.boot index 56588e73..edc6f9f5 100644 --- a/src/interp/nag-e02.boot +++ b/src/interp/nag-e02.boot @@ -1,5 +1,7 @@ -- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are diff --git a/src/interp/nag-e02b.boot b/src/interp/nag-e02b.boot index aa307b1b..6a523ba2 100644 --- a/src/interp/nag-e02b.boot +++ b/src/interp/nag-e02b.boot @@ -1,5 +1,7 @@ -- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are diff --git a/src/interp/nag-e04.boot b/src/interp/nag-e04.boot index e20eb98e..860b3d38 100644 --- a/src/interp/nag-e04.boot +++ b/src/interp/nag-e04.boot @@ -1,5 +1,7 @@ -- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are diff --git a/src/interp/nag-f01.boot b/src/interp/nag-f01.boot index bbb511b6..3a6ddaa3 100644 --- a/src/interp/nag-f01.boot +++ b/src/interp/nag-f01.boot @@ -1,5 +1,7 @@ -- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are diff --git a/src/interp/nag-f02.boot b/src/interp/nag-f02.boot index f0cb92ed..d93b65e6 100644 --- a/src/interp/nag-f02.boot +++ b/src/interp/nag-f02.boot @@ -1,5 +1,7 @@ -- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are diff --git a/src/interp/nag-f04.boot b/src/interp/nag-f04.boot index 2d50f701..39498a45 100644 --- a/src/interp/nag-f04.boot +++ b/src/interp/nag-f04.boot @@ -1,5 +1,7 @@ -- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are diff --git a/src/interp/nag-f07.boot b/src/interp/nag-f07.boot index 1784e006..bbc690a8 100644 --- a/src/interp/nag-f07.boot +++ b/src/interp/nag-f07.boot @@ -1,5 +1,7 @@ -- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are diff --git a/src/interp/nag-s.boot b/src/interp/nag-s.boot index e2eed84a..5b9051b2 100644 --- a/src/interp/nag-s.boot +++ b/src/interp/nag-s.boot @@ -1,5 +1,7 @@ -- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are diff --git a/src/interp/osyscmd.boot b/src/interp/osyscmd.boot new file mode 100644 index 00000000..c26a4246 --- /dev/null +++ b/src/interp/osyscmd.boot @@ -0,0 +1,55 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- 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" + + +InterpExecuteSpadSystemCommand string == + CATCH($intCoerceFailure, + CATCH($intSpadReader, ExecuteInterpSystemCommand string) ) + +ExecuteInterpSystemCommand string == + string := intProcessSynonyms(string) + $currentLine:local:=string + string:=SUBSTRING(string,1,nil) + string = '"" => nil + doSystemCommand string + +--------------------> NEW DEFINITION (see i-syscmd.boot.pamphlet) +parseFromString(s) == + s := next(function ncloopParse, + next(function lineoftoks,incString s)) + StreamNull s => nil + pf2Sex macroExpanded first rest first s + diff --git a/src/interp/osyscmd.boot.pamphlet b/src/interp/osyscmd.boot.pamphlet deleted file mode 100644 index c1afede2..00000000 --- a/src/interp/osyscmd.boot.pamphlet +++ /dev/null @@ -1,75 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp osyscmd.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\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" - - -InterpExecuteSpadSystemCommand string == - CATCH($intCoerceFailure, - CATCH($intSpadReader, ExecuteInterpSystemCommand string) ) - -ExecuteInterpSystemCommand string == - string := intProcessSynonyms(string) - $currentLine:local:=string - string:=SUBSTRING(string,1,nil) - string = '"" => nil - doSystemCommand string - ---------------------> NEW DEFINITION (see i-syscmd.boot.pamphlet) -parseFromString(s) == - s := next(function ncloopParse, - next(function lineoftoks,incString s)) - StreamNull s => nil - pf2Sex macroExpanded first rest first s - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/package.boot b/src/interp/package.boot new file mode 100644 index 00000000..afb54051 --- /dev/null +++ b/src/interp/package.boot @@ -0,0 +1,276 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- 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" + +isPackageFunction() == + -- called by compile/putInLocalDomainReferences +--+ + nil + +processFunctorOrPackage(form,signature,data,localParList,m,e) == +--+ + processFunctor(form,signature,data,localParList,e) + +processPackage($definition is [name,:args],[$catsig,:argssig],code,locals,$e) == + $GENNO: local:= 0 --for GENVAR() + $catsig: local + --used in ProcessCond + $maximalViews: local + --read by ProcessCond + $ResetItems: local + --stores those items that get SETQed, and may need re-processing + $catvecList: local:= [$domainShell] + $catNames: local:= ["$"] +--PRINT $definition +--PRINT ($catsig,:argssig) +--PRETTYPRINT code + catvec:= $domainShell --from compDefineFunctor + $getDomainCode:= optFunctorBody $getDomainCode + --the purpose of this is so ProcessCond recognises such items + code:= PackageDescendCode(code,true,nil) + if delete(nil,locals) then code:=[:code,:(setPackageCode locals)] where + setPackageCode locals == + locals':=[[u,:i] for u in locals for i in 0.. | u] + locals'' :=[] + while locals' repeat + for v in locals' repeat + [u,:i]:=v + if and/[EQ(v,v') or not subTree(u,CAR v') for v' in locals'] + then + locals'':=[v,:locals''] + locals':=delete(v,locals') + precomp:=code:=[] + for elem in locals'' repeat + [u,:i]:=elem + if ATOM u then u':=u + else + u':=opt(u,precomp) where + opt(u,alist) == + ATOM u => u + for v in u repeat + if (a:=ASSOC(v,alist)) then + [.,:i]:=a + u:=replace(v,[($QuickCode=>'QREFELT;'ELT),"$",i],u) where + replace(old,new,l) == + l isnt [h,:t] => l + h = old => [new,:t] + [h,:replace(old,new,t)] + v':=opt(v,alist) + EQ(v,v') => nil + u:=replace(v,v',u) + u + precomp:=[elem,:precomp] + code:=[[($QuickCode=>'QSETREFV;'SETELT),"$",i,u'],:code] + nreverse code + code:= + ["PROGN",:$getDomainCode,["LET","$",["GETREFV",#locals]], + --It is important to place this code here, + --after $ is set up + --slam functor with shell + --the order of steps in this PROGN are critical + addToSlam($definition,"$"),code,[ + "SETELT","$",0, mkDomainConstructor $definition],: +-- If we call addMutableArg this early, then recurise calls to this domain +-- (e.g. while testing predicates) will generate new domains => trouble +-- "SETELT","$",0,addMutableArg mkDomainConstructor $definition],: + [["SETELT","$",position(name,locals),name] + for name in $ResetItems | MEMQ(name,locals)], + :[($mutableDomain => '(RPLACD (LASTNODE (ELT $ 0)) + (LIST (GENSYM)));[]) ], + "$"] + for u in $getDomainCode repeat + u is ['LET,.,u'] and u' is ['getDomainView,.,u''] => + $packagesUsed:=union(CategoriesFromGDC u'',$packagesUsed) + $packagesUsed:=union($functorLocalParameters,$packagesUsed) + $getDomainCode:= nil + --if we didn't kill this, DEFINE would insert it in the wrong place + optFunctorBody code + +subTree(u,v) == + v=u => true + ATOM v => nil + or/[subTree(u,v') for v' in v] + +mkList u == + u => ["LIST",:u] + nil + +setPackageLocals(pac,locs) == + for var in locs for i in 0.. | var^=nil repeat pac.i:= var + +PackageDescendCode(code,flag,viewAssoc) == + --flag is true if we are walking down code always executed + --nil if we are in conditional code + code=nil => nil + code="noBranch" => nil + code is ["add",base,:codelist] => + systemError '"packages may not have add clauses" + code is ["PROGN",:codelist] => + ["PROGN",: + [v for u in codelist | (v:= PackageDescendCode(u,flag,viewAssoc))^=nil]] + code is ["COND",:condlist] => + c:= + ["COND",: + [[u2:= ProcessCond(first u,viewAssoc),: + (if null u2 + then nil + else + [PackageDescendCode(v,flag and TruthP u2, + if first u is ["HasCategory",dom,cat] + then [[dom,:cat],:viewAssoc] + else viewAssoc) for v in rest u])] for u in condlist]] + TruthP CAADR c => ["PROGN",:CDADR c] + c + code is ["LET",name,body,:.] => + if not MEMQ(name,$ResetItems) then $ResetItems:= [name,:$ResetItems] + if body is [a,:.] and isFunctor a + then $packagesUsed:=[body,:$packagesUsed] + code + code is ["CodeDefine",sig,implem] => + --Generated by doIt in COMPILER BOOT + dom:= "$" + dom:= + u:= LASSOC(dom,viewAssoc) => ["getDomainView",dom,u] + dom + body:= ["CONS",implem,dom] + SetFunctionSlots(sig,body,flag,"original") + code is [":",:.] => (RPLACA(code,"LIST"); RPLACD(code,NIL)) + --Yes, I know that's a hack, but how else do you kill a line? + code is ["LIST",:.] => nil + code is ["MDEF",:.] => nil + code is ["devaluate",:.] => nil + code is ["call",:.] => code + code is ["SETELT",:.] => code + code is ["QSETREFV",:.] => code + stackWarning ["unknown Package code ",code] + code + +mkOperatorEntry(domainOrPackage,opSig is [op,sig,:flag],pred,count) == + domainOrPackage^="domain" => + [opSig,pred,["PAC","$",name]] where + name() == encodeFunctionName(op,domainOrPackage,sig,":",count) + null flag => [opSig,pred,["ELT","$",count]] + first flag="constant" => [[op,sig],pred,["CONST","$",count]] + systemError ["unknown variable mode: ",flag] + +optPackageCall(x,["PAC",packageVariableOrForm,functionName],arglist) == + RPLACA(x,functionName) + RPLACD(x,[:arglist,packageVariableOrForm]) + x + +--% Code for encoding function names inside package or domain + +encodeFunctionName(fun,package is [packageName,:arglist],signature,sep,count) + == + signature':= substitute("$",package,signature) + reducedSig:= mkRepititionAssoc [:rest signature',first signature'] + encodedSig:= + ("STRCONC"/[encodedPair for [n,:x] in reducedSig]) where + encodedPair() == + n=1 => encodeItem x + STRCONC(STRINGIMAGE n,encodeItem x) + encodedName:= INTERNL(getAbbreviation(packageName,#arglist),";", + encodeItem fun,";",encodedSig, sep,STRINGIMAGE count) + if $LISPLIB then + $lisplibSignatureAlist:= + [[encodedName,:signature'],:$lisplibSignatureAlist] + encodedName + +splitEncodedFunctionName(encodedName, sep) == + -- [encodedPackage, encodedItem, encodedSig, sequenceNo] or NIL + -- sep0 is the separator used in "encodeFunctionName". + sep0 := '";" + if not STRINGP encodedName then + encodedName := STRINGIMAGE encodedName + null (p1 := STRPOS(sep0, encodedName, 0, '"*")) => nil + null (p2 := STRPOS(sep0, encodedName, p1+1, '"*")) => 'inner +-- This is picked up in compile for inner functions in partial compilation + null (p3 := STRPOS(sep, encodedName, p2+1, '"*")) => nil + s1 := SUBSTRING(encodedName, 0, p1) + s2 := SUBSTRING(encodedName, p1+1, p2-p1-1) + s3 := SUBSTRING(encodedName, p2+1, p3-p2-1) + s4 := SUBSTRING(encodedName, p3+1, nil) + [s1, s2, s3, s4] + +mkRepititionAssoc l == + mkRepfun(l,1) where + mkRepfun(l,n) == + null l => nil + l is [x] => [[n,:x]] + l is [x, =x,:l'] => mkRepfun(rest l,n+1) + [[n,:first l],:mkRepfun(rest l,1)] + +encodeItem x == + x is [op,:argl] => getCaps op + IDENTP x => PNAME x + STRINGIMAGE x + +getCaps x == + s:= STRINGIMAGE x + clist:= [c for i in 0..MAXINDEX s | UPPER_-CASE_-P (c:= s.i)] + null clist => '"__" + "STRCONC"/[first clist,:[L_-CASE u for u in rest clist]] + +--% abbreviation code + +getAbbreviation(name,c) == + --returns abbreviation of name with c arguments + x := constructor? name + X := ASSQ(x,$abbreviationTable) => + N:= ASSQ(name,rest X) => + C:= ASSQ(c,rest N) => rest C --already there + newAbbreviation:= mkAbbrev(X,x) + RPLAC(rest N,[[c,:newAbbreviation],:rest N]) + newAbbreviation + newAbbreviation:= mkAbbrev(X,x) + RPLAC(rest X,[[name,[c,:newAbbreviation]],:rest X]) + newAbbreviation + $abbreviationTable:= [[x,[name,[c,:x]]],:$abbreviationTable] + x + +mkAbbrev(X,x) == addSuffix(alistSize rest X,x) + +alistSize c == + count(c,1) where + count(x,level) == + level=2 => #x + null x => 0 + count(CDAR x,level+1)+count(rest x,level) + +addSuffix(n,u) == + ALPHA_-CHAR_-P (s:= STRINGIMAGE u).(MAXINDEX s) => INTERN STRCONC(s,STRINGIMAGE n) + INTERNL STRCONC(s,STRINGIMAGE ";",STRINGIMAGE n) + + diff --git a/src/interp/package.boot.pamphlet b/src/interp/package.boot.pamphlet deleted file mode 100644 index f97f86ac..00000000 --- a/src/interp/package.boot.pamphlet +++ /dev/null @@ -1,300 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/package.boot} Pamphlet} -\author{The Axiom Team} - -\begin{document} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\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" - -isPackageFunction() == - -- called by compile/putInLocalDomainReferences ---+ - nil - -processFunctorOrPackage(form,signature,data,localParList,m,e) == ---+ - processFunctor(form,signature,data,localParList,e) - -processPackage($definition is [name,:args],[$catsig,:argssig],code,locals,$e) == - $GENNO: local:= 0 --for GENVAR() - $catsig: local - --used in ProcessCond - $maximalViews: local - --read by ProcessCond - $ResetItems: local - --stores those items that get SETQed, and may need re-processing - $catvecList: local:= [$domainShell] - $catNames: local:= ["$"] ---PRINT $definition ---PRINT ($catsig,:argssig) ---PRETTYPRINT code - catvec:= $domainShell --from compDefineFunctor - $getDomainCode:= optFunctorBody $getDomainCode - --the purpose of this is so ProcessCond recognises such items - code:= PackageDescendCode(code,true,nil) - if delete(nil,locals) then code:=[:code,:(setPackageCode locals)] where - setPackageCode locals == - locals':=[[u,:i] for u in locals for i in 0.. | u] - locals'' :=[] - while locals' repeat - for v in locals' repeat - [u,:i]:=v - if and/[EQ(v,v') or not subTree(u,CAR v') for v' in locals'] - then - locals'':=[v,:locals''] - locals':=delete(v,locals') - precomp:=code:=[] - for elem in locals'' repeat - [u,:i]:=elem - if ATOM u then u':=u - else - u':=opt(u,precomp) where - opt(u,alist) == - ATOM u => u - for v in u repeat - if (a:=ASSOC(v,alist)) then - [.,:i]:=a - u:=replace(v,[($QuickCode=>'QREFELT;'ELT),"$",i],u) where - replace(old,new,l) == - l isnt [h,:t] => l - h = old => [new,:t] - [h,:replace(old,new,t)] - v':=opt(v,alist) - EQ(v,v') => nil - u:=replace(v,v',u) - u - precomp:=[elem,:precomp] - code:=[[($QuickCode=>'QSETREFV;'SETELT),"$",i,u'],:code] - nreverse code - code:= - ["PROGN",:$getDomainCode,["LET","$",["GETREFV",#locals]], - --It is important to place this code here, - --after $ is set up - --slam functor with shell - --the order of steps in this PROGN are critical - addToSlam($definition,"$"),code,[ - "SETELT","$",0, mkDomainConstructor $definition],: --- If we call addMutableArg this early, then recurise calls to this domain --- (e.g. while testing predicates) will generate new domains => trouble --- "SETELT","$",0,addMutableArg mkDomainConstructor $definition],: - [["SETELT","$",position(name,locals),name] - for name in $ResetItems | MEMQ(name,locals)], - :[($mutableDomain => '(RPLACD (LASTNODE (ELT $ 0)) - (LIST (GENSYM)));[]) ], - "$"] - for u in $getDomainCode repeat - u is ['LET,.,u'] and u' is ['getDomainView,.,u''] => - $packagesUsed:=union(CategoriesFromGDC u'',$packagesUsed) - $packagesUsed:=union($functorLocalParameters,$packagesUsed) - $getDomainCode:= nil - --if we didn't kill this, DEFINE would insert it in the wrong place - optFunctorBody code - -subTree(u,v) == - v=u => true - ATOM v => nil - or/[subTree(u,v') for v' in v] - -mkList u == - u => ["LIST",:u] - nil - -setPackageLocals(pac,locs) == - for var in locs for i in 0.. | var^=nil repeat pac.i:= var - -PackageDescendCode(code,flag,viewAssoc) == - --flag is true if we are walking down code always executed - --nil if we are in conditional code - code=nil => nil - code="noBranch" => nil - code is ["add",base,:codelist] => - systemError '"packages may not have add clauses" - code is ["PROGN",:codelist] => - ["PROGN",: - [v for u in codelist | (v:= PackageDescendCode(u,flag,viewAssoc))^=nil]] - code is ["COND",:condlist] => - c:= - ["COND",: - [[u2:= ProcessCond(first u,viewAssoc),: - (if null u2 - then nil - else - [PackageDescendCode(v,flag and TruthP u2, - if first u is ["HasCategory",dom,cat] - then [[dom,:cat],:viewAssoc] - else viewAssoc) for v in rest u])] for u in condlist]] - TruthP CAADR c => ["PROGN",:CDADR c] - c - code is ["LET",name,body,:.] => - if not MEMQ(name,$ResetItems) then $ResetItems:= [name,:$ResetItems] - if body is [a,:.] and isFunctor a - then $packagesUsed:=[body,:$packagesUsed] - code - code is ["CodeDefine",sig,implem] => - --Generated by doIt in COMPILER BOOT - dom:= "$" - dom:= - u:= LASSOC(dom,viewAssoc) => ["getDomainView",dom,u] - dom - body:= ["CONS",implem,dom] - SetFunctionSlots(sig,body,flag,"original") - code is [":",:.] => (RPLACA(code,"LIST"); RPLACD(code,NIL)) - --Yes, I know that's a hack, but how else do you kill a line? - code is ["LIST",:.] => nil - code is ["MDEF",:.] => nil - code is ["devaluate",:.] => nil - code is ["call",:.] => code - code is ["SETELT",:.] => code - code is ["QSETREFV",:.] => code - stackWarning ["unknown Package code ",code] - code - -mkOperatorEntry(domainOrPackage,opSig is [op,sig,:flag],pred,count) == - domainOrPackage^="domain" => - [opSig,pred,["PAC","$",name]] where - name() == encodeFunctionName(op,domainOrPackage,sig,":",count) - null flag => [opSig,pred,["ELT","$",count]] - first flag="constant" => [[op,sig],pred,["CONST","$",count]] - systemError ["unknown variable mode: ",flag] - -optPackageCall(x,["PAC",packageVariableOrForm,functionName],arglist) == - RPLACA(x,functionName) - RPLACD(x,[:arglist,packageVariableOrForm]) - x - ---% Code for encoding function names inside package or domain - -encodeFunctionName(fun,package is [packageName,:arglist],signature,sep,count) - == - signature':= substitute("$",package,signature) - reducedSig:= mkRepititionAssoc [:rest signature',first signature'] - encodedSig:= - ("STRCONC"/[encodedPair for [n,:x] in reducedSig]) where - encodedPair() == - n=1 => encodeItem x - STRCONC(STRINGIMAGE n,encodeItem x) - encodedName:= INTERNL(getAbbreviation(packageName,#arglist),";", - encodeItem fun,";",encodedSig, sep,STRINGIMAGE count) - if $LISPLIB then - $lisplibSignatureAlist:= - [[encodedName,:signature'],:$lisplibSignatureAlist] - encodedName - -splitEncodedFunctionName(encodedName, sep) == - -- [encodedPackage, encodedItem, encodedSig, sequenceNo] or NIL - -- sep0 is the separator used in "encodeFunctionName". - sep0 := '";" - if not STRINGP encodedName then - encodedName := STRINGIMAGE encodedName - null (p1 := STRPOS(sep0, encodedName, 0, '"*")) => nil - null (p2 := STRPOS(sep0, encodedName, p1+1, '"*")) => 'inner --- This is picked up in compile for inner functions in partial compilation - null (p3 := STRPOS(sep, encodedName, p2+1, '"*")) => nil - s1 := SUBSTRING(encodedName, 0, p1) - s2 := SUBSTRING(encodedName, p1+1, p2-p1-1) - s3 := SUBSTRING(encodedName, p2+1, p3-p2-1) - s4 := SUBSTRING(encodedName, p3+1, nil) - [s1, s2, s3, s4] - -mkRepititionAssoc l == - mkRepfun(l,1) where - mkRepfun(l,n) == - null l => nil - l is [x] => [[n,:x]] - l is [x, =x,:l'] => mkRepfun(rest l,n+1) - [[n,:first l],:mkRepfun(rest l,1)] - -encodeItem x == - x is [op,:argl] => getCaps op - IDENTP x => PNAME x - STRINGIMAGE x - -getCaps x == - s:= STRINGIMAGE x - clist:= [c for i in 0..MAXINDEX s | UPPER_-CASE_-P (c:= s.i)] - null clist => '"__" - "STRCONC"/[first clist,:[L_-CASE u for u in rest clist]] - ---% abbreviation code - -getAbbreviation(name,c) == - --returns abbreviation of name with c arguments - x := constructor? name - X := ASSQ(x,$abbreviationTable) => - N:= ASSQ(name,rest X) => - C:= ASSQ(c,rest N) => rest C --already there - newAbbreviation:= mkAbbrev(X,x) - RPLAC(rest N,[[c,:newAbbreviation],:rest N]) - newAbbreviation - newAbbreviation:= mkAbbrev(X,x) - RPLAC(rest X,[[name,[c,:newAbbreviation]],:rest X]) - newAbbreviation - $abbreviationTable:= [[x,[name,[c,:x]]],:$abbreviationTable] - x - -mkAbbrev(X,x) == addSuffix(alistSize rest X,x) - -alistSize c == - count(c,1) where - count(x,level) == - level=2 => #x - null x => 0 - count(CDAR x,level+1)+count(rest x,level) - -addSuffix(n,u) == - ALPHA_-CHAR_-P (s:= STRINGIMAGE u).(MAXINDEX s) => INTERN STRCONC(s,STRINGIMAGE n) - INTERNL STRCONC(s,STRINGIMAGE ";",STRINGIMAGE n) - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/packtran.boot b/src/interp/packtran.boot new file mode 100644 index 00000000..b61683b9 --- /dev/null +++ b/src/interp/packtran.boot @@ -0,0 +1,62 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- 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" + +-- The $useNewParser flag controls which parser will be used in the interpreter +-- If nil then the old parser is used, otherwise Bill Burge's parser is used +$useNewParser := true + +rePackageTran(sex, package) == + _*PACKAGE_* : fluid := FIND_-PACKAGE STRING package + packageTran sex + +packageTran sex == +-- destructively translate all the symbols in the given s-expression to the +-- current package + SYMBOLP sex => + EQ(_*PACKAGE_*, SYMBOL_-PACKAGE sex) => sex + INTERN STRING sex + CONSP sex => + RPLACA(sex, packageTran CAR sex) + RPLACD(sex, packageTran CDR sex) + sex + sex + +zeroOneTran sex == +-- destructively translate the symbols |0| and |1| to their +-- integer counterparts + NSUBST("$EmptyMode", "?", sex) + sex + diff --git a/src/interp/packtran.boot.pamphlet b/src/interp/packtran.boot.pamphlet deleted file mode 100644 index b1814ddf..00000000 --- a/src/interp/packtran.boot.pamphlet +++ /dev/null @@ -1,86 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\$SPAD/src/interp packtran.boot} -\author{The Axiom Team} - -\begin{document} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\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" - --- The $useNewParser flag controls which parser will be used in the interpreter --- If nil then the old parser is used, otherwise Bill Burge's parser is used -$useNewParser := true - -rePackageTran(sex, package) == - _*PACKAGE_* : fluid := FIND_-PACKAGE STRING package - packageTran sex - -packageTran sex == --- destructively translate all the symbols in the given s-expression to the --- current package - SYMBOLP sex => - EQ(_*PACKAGE_*, SYMBOL_-PACKAGE sex) => sex - INTERN STRING sex - CONSP sex => - RPLACA(sex, packageTran CAR sex) - RPLACD(sex, packageTran CDR sex) - sex - sex - -zeroOneTran sex == --- destructively translate the symbols |0| and |1| to their --- integer counterparts - NSUBST("$EmptyMode", "?", sex) - sex - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/pathname.boot b/src/interp/pathname.boot new file mode 100644 index 00000000..fc3f882a --- /dev/null +++ b/src/interp/pathname.boot @@ -0,0 +1,146 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- 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" + +-- This file implements the Common Lisp pathname functions for +-- Lisp/VM. On VM, a filename is 3-list consisting of the filename, +-- filetype and filemode. We also UPCASE everything. + +-- This file also contains some other VM specific functions for +-- dealing with files. + +--% Common Lisp Pathname Functions + +pathname? p == p=[] or PATHNAMEP p + +pathname p == + p = [] => p + PATHNAMEP p => p + not PAIRP p => PATHNAME p + if #p>2 then p:=[p.0,p.1] + PATHNAME APPLY(FUNCTION MAKE_-FILENAME, p) + +namestring p == NAMESTRING pathname p + +pathnameName p == PATHNAME_-NAME pathname p + +pathnameType p == PATHNAME_-TYPE pathname p + +pathnameTypeId p == UPCASE object2Identifier pathnameType p + +pathnameDirectory p == + NAMESTRING MAKE_-PATHNAME(LispKeyword '"DIRECTORY",PATHNAME_-DIRECTORY pathname p) + +deleteFile f == _$ERASE pathname f + +isExistingFile f == +-- p := pathname f + --member(p,$existingFiles) => true + if MAKE_-INPUT_-FILENAME f + then + --$existingFiles := [p,:$existingFiles] + true + else false + +--% Scratchpad II File Name Functions + +makePathname(name,type,dir) == + -- Common Lisp version of this will have to be written + -- using MAKE-PATHNAME and the optional args. + pathname [object2String name,object2String type] + +mergePathnames(a,b) == + (fn := pathnameName(a)) = '"*" => b + fn ^= pathnameName(b) => a + (ft := pathnameType(a)) = '"*" => b + ft ^= pathnameType(b) => a + (fm := pathnameDirectory(a)) = ['"*"] => b + a + +isSystemDirectory dir == + EVERY(function CHAR_=,systemRootDirectory(),dir) + +-- the next function is an improved version of the one in DEBUG LISP + +_/MKINFILENAM(infile) == CATCH('FILNAM, newMKINFILENAM infile) + +newMKINFILENAM(infile) == + NULL infile => nil + file := infile := pathname infile + repeat + fn := pathnameName file + nfile := $FINDFILE (file,$sourceFileTypes) + null nfile => + nfile := file + if fn = '"*" or fn = '"NIL" then sayKeyedMsg("S2IL0016",NIL) + else sayKeyedMsg("S2IL0003",[namestring file]) + ans := queryUserKeyedMsg("S2IL0017",NIL) + if (SIZE(ans) > 0) and ('")" = SUBSTRING(ans,0,1)) then n := 2 + else n := 1 + nfn := UPCASE STRING2ID_-N(ans,n) + (nfn = 0) or (nfn = 'QUIT) => + sayKeyedMsg("S2IL0018",NIL) + THROW('FILENAM,NIL) + nfn = 'CREATE => return 'fromThisLoop + file := pathname ans + return 'fromThisLoop + if nfile then pathname nfile + else NIL + + +getFunctionSourceFile fun == + null (f := getFunctionSourceFile1 fun) => NIL + if MAKE_-INPUT_-FILENAME(f) then updateSourceFiles f + f + +getFunctionSourceFile1 fun == + -- returns NIL or [fn,ft,fm] + (file := KDR GETL(fun,'DEFLOC)) => pathname file + null ((fileinfo := FUNLOC fun) or + (fileinfo := FUNLOC unabbrev fun)) => + u := bootFind fun => getFunctionSourceFile1 SETQ($FUNCTION,INTERN u) + NIL + 3 = #fileinfo => + [fn,ft,$FUNCTION] := fileinfo + newMKINFILENAM pathname [fn,ft] + [fn,$FUNCTION] := fileinfo + newMKINFILENAM pathname [fn] + +updateSourceFiles p == + p := pathname p + p := pathname [pathnameName p, pathnameType p, '"*"] + if MAKE_-INPUT_-FILENAME p and pathnameTypeId p in '(BOOT LISP META) then + $sourceFiles := insert(p, $sourceFiles) + p diff --git a/src/interp/pathname.boot.pamphlet b/src/interp/pathname.boot.pamphlet deleted file mode 100644 index cab703d1..00000000 --- a/src/interp/pathname.boot.pamphlet +++ /dev/null @@ -1,166 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp pathname.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\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" - --- This file implements the Common Lisp pathname functions for --- Lisp/VM. On VM, a filename is 3-list consisting of the filename, --- filetype and filemode. We also UPCASE everything. - --- This file also contains some other VM specific functions for --- dealing with files. - ---% Common Lisp Pathname Functions - -pathname? p == p=[] or PATHNAMEP p - -pathname p == - p = [] => p - PATHNAMEP p => p - not PAIRP p => PATHNAME p - if #p>2 then p:=[p.0,p.1] - PATHNAME APPLY(FUNCTION MAKE_-FILENAME, p) - -namestring p == NAMESTRING pathname p - -pathnameName p == PATHNAME_-NAME pathname p - -pathnameType p == PATHNAME_-TYPE pathname p - -pathnameTypeId p == UPCASE object2Identifier pathnameType p - -pathnameDirectory p == - NAMESTRING MAKE_-PATHNAME(LispKeyword '"DIRECTORY",PATHNAME_-DIRECTORY pathname p) - -deleteFile f == _$ERASE pathname f - -isExistingFile f == --- p := pathname f - --member(p,$existingFiles) => true - if MAKE_-INPUT_-FILENAME f - then - --$existingFiles := [p,:$existingFiles] - true - else false - ---% Scratchpad II File Name Functions - -makePathname(name,type,dir) == - -- Common Lisp version of this will have to be written - -- using MAKE-PATHNAME and the optional args. - pathname [object2String name,object2String type] - -mergePathnames(a,b) == - (fn := pathnameName(a)) = '"*" => b - fn ^= pathnameName(b) => a - (ft := pathnameType(a)) = '"*" => b - ft ^= pathnameType(b) => a - (fm := pathnameDirectory(a)) = ['"*"] => b - a - -isSystemDirectory dir == - EVERY(function CHAR_=,systemRootDirectory(),dir) - --- the next function is an improved version of the one in DEBUG LISP - -_/MKINFILENAM(infile) == CATCH('FILNAM, newMKINFILENAM infile) - -newMKINFILENAM(infile) == - NULL infile => nil - file := infile := pathname infile - repeat - fn := pathnameName file - nfile := $FINDFILE (file,$sourceFileTypes) - null nfile => - nfile := file - if fn = '"*" or fn = '"NIL" then sayKeyedMsg("S2IL0016",NIL) - else sayKeyedMsg("S2IL0003",[namestring file]) - ans := queryUserKeyedMsg("S2IL0017",NIL) - if (SIZE(ans) > 0) and ('")" = SUBSTRING(ans,0,1)) then n := 2 - else n := 1 - nfn := UPCASE STRING2ID_-N(ans,n) - (nfn = 0) or (nfn = 'QUIT) => - sayKeyedMsg("S2IL0018",NIL) - THROW('FILENAM,NIL) - nfn = 'CREATE => return 'fromThisLoop - file := pathname ans - return 'fromThisLoop - if nfile then pathname nfile - else NIL - - -getFunctionSourceFile fun == - null (f := getFunctionSourceFile1 fun) => NIL - if MAKE_-INPUT_-FILENAME(f) then updateSourceFiles f - f - -getFunctionSourceFile1 fun == - -- returns NIL or [fn,ft,fm] - (file := KDR GETL(fun,'DEFLOC)) => pathname file - null ((fileinfo := FUNLOC fun) or - (fileinfo := FUNLOC unabbrev fun)) => - u := bootFind fun => getFunctionSourceFile1 SETQ($FUNCTION,INTERN u) - NIL - 3 = #fileinfo => - [fn,ft,$FUNCTION] := fileinfo - newMKINFILENAM pathname [fn,ft] - [fn,$FUNCTION] := fileinfo - newMKINFILENAM pathname [fn] - -updateSourceFiles p == - p := pathname p - p := pathname [pathnameName p, pathnameType p, '"*"] - if MAKE_-INPUT_-FILENAME p and pathnameTypeId p in '(BOOT LISP META) then - $sourceFiles := insert(p, $sourceFiles) - p -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/pf2sex.boot b/src/interp/pf2sex.boot new file mode 100644 index 00000000..bde56323 --- /dev/null +++ b/src/interp/pf2sex.boot @@ -0,0 +1,463 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- 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" + +$dotdot := INTERN('"..", '"BOOT") +$specificMsgTags := nil + +-- Pftree to s-expression translation. Used to interface the new parser +-- technology to the interpreter. The input is a parseTree and the +-- output is an old-parser-style s-expression + +pf2Sex pf == + intUnsetQuiet() + $insideRule:local := false + $insideApplication: local := false + $insideSEQ: local := false + pf2Sex1 pf + +pf2Sex1 pf == + pfNothing? pf => + "noBranch" + pfSymbol? pf => + $insideRule = 'left => + s := pfSymbolSymbol pf + ["constant", ["QUOTE", s]] + ["QUOTE", pfSymbolSymbol pf] + pfLiteral? pf => + pfLiteral2Sex pf + pfId? pf => + $insideRule => + s := pfIdSymbol pf + SymMemQ(s, '(%pi %e %i)) => s + ["QUOTE", s] + pfIdSymbol pf + pfApplication? pf => + pfApplication2Sex pf + pfTuple? pf => + ["Tuple", :[pf2Sex1 x for x in pf0TupleParts pf]] + pfIf? pf => + ['IF, pf2Sex1 pfIfCond pf, pf2Sex1 pfIfThen pf, pf2Sex1 pfIfElse pf] + pfTagged? pf => + tag := pfTaggedTag pf + tagPart := + pfTuple? tag => + ['Tuple, :[pf2Sex1 arg for arg in pf0TupleParts tag]] + pf2Sex1 tag + [":", tagPart, pf2Sex1 pfTaggedExpr pf] + pfCoerceto? pf => + ["::", pf2Sex1 pfCoercetoExpr pf, pf2Sex1 pfCoercetoType pf] + pfPretend? pf => + ["pretend", pf2Sex1 pfPretendExpr pf, pf2Sex1 pfPretendType pf] + pfFromdom? pf => + op := opTran pf2Sex1 pfFromdomWhat pf +-- if op = "braceFromCurly" then op := "brace" + if op = "braceFromCurly" then op := "SEQ" + ["$elt", pf2Sex1 pfFromdomDomain pf, op] + pfSequence? pf => + pfSequence2Sex pf + pfExit? pf => + $insideSEQ => ["exit", pf2Sex1 pfExitCond pf, pf2Sex1 pfExitExpr pf] + ["IF", pf2Sex1 pfExitCond pf, pf2Sex1 pfExitExpr pf, "noBranch"] + pfLoop? pf => + ["REPEAT", :loopIters2Sex pf0LoopIterators pf] + pfCollect? pf => + pfCollect2Sex pf + pfForin? pf => + ["IN", :[pf2Sex1 x for x in pf0ForinLhs pf], pf2Sex1 pfForinWhole pf] + pfWhile? pf => + ["WHILE", pf2Sex1 pfWhileCond pf] + pfSuchthat? pf => + $insideRule = 'left => + keyedSystemError('"S2GE0017", ['"pf2Sex1: pfSuchThat"]) + ["|", pf2Sex1 pfSuchthatCond pf] + pfDo? pf => + pf2Sex1 pfDoBody pf + pfTyped? pf => + type := pfTypedType pf + pfNothing? type => pf2Sex1 pfTypedId pf + [":", pf2Sex1 pfTypedId pf, pf2Sex1 pfTypedType pf] + pfAssign? pf => + idList := [pf2Sex1 x for x in pf0AssignLhsItems pf] + if #idList ^= 1 then idList := ['Tuple, :idList] + else idList := first idList + ["LET", idList, pf2Sex1 pfAssignRhs pf] + pfDefinition? pf => + pfDefinition2Sex pf + pfLambda? pf => + pfLambda2Sex pf + pfMLambda? pf => + "/throwAway" + pfRestrict? pf => + ["@", pf2Sex1 pfRestrictExpr pf, pf2Sex1 pfRestrictType pf] + pfFree? pf => + ['free, :[pf2Sex1 item for item in pf0FreeItems pf]] + pfLocal? pf => + ['local, :[pf2Sex1 item for item in pf0LocalItems pf]] + pfWrong? pf => + spadThrow() + pfAnd? pf => + ["and", pf2Sex1 pfAndLeft pf, pf2Sex1 pfAndRight pf] + pfOr? pf => + ["or", pf2Sex1 pfOrLeft pf, pf2Sex1 pfOrRight pf] + pfNot? pf => + ["not", pf2Sex1 pfNotArg pf] + pfNovalue? pf => + intSetQuiet() + ["SEQ", pf2Sex1 pfNovalueExpr pf] + pfRule? pf => + pfRule2Sex pf + pfBreak? pf => + ["break", pfBreakFrom pf] + pfMacro? pf => + "/throwAway" + pfReturn? pf => + ["return", pf2Sex1 pfReturnExpr pf] + pfIterate? pf => + ["iterate"] + pfWhere? pf => + args := [pf2Sex1 p for p in pf0WhereContext pf] + #args = 1 => + ["where", pf2Sex1 pfWhereExpr pf, :args] + ["where", pf2Sex1 pfWhereExpr pf, ["SEQ", :args]] + + -- under strange circumstances/piling, system commands can wind + -- up in expressions. This just passes it through as a string for + -- the user to figure out what happened. + pfAbSynOp(pf) = "command" => tokPart(pf) + + keyedSystemError('"S2GE0017", ['"pf2Sex1"]) + +pfLiteral2Sex pf == + type := pfLiteralClass pf + type = 'integer => + READ_-FROM_-STRING pfLiteralString pf + type = 'string or type = 'char => + pfLiteralString pf + type = 'float => + float2Sex pfLiteralString pf + type = 'symbol => + $insideRule => + s := pfSymbolSymbol pf + ["QUOTE", s] + pfSymbolSymbol pf + type = 'expression => + ["QUOTE", pfLeafToken pf] + keyedSystemError('"S2GE0017", ['"pfLiteral2Sex: unexpected form"]) + +symEqual(sym, sym2) == EQ(sym, sym2) + +SymMemQ(sy, l) == MEMQ(sy, l) + +pmDontQuote? sy == + SymMemQ(sy, '(_+ _- _* _*_* _^ _/ log exp pi sqrt ei li erf ci si dilog _ + sin cos tan cot sec csc asin acos atan acot asec acsc _ + sinh cosh tanh coth sech csch asinh acosh atanh acoth asech acsc)) + +pfOp2Sex pf == + alreadyQuoted := pfSymbol? pf + op := pf2Sex1 pf + op is ["QUOTE", realOp] => + $insideRule = 'left => realOp + $insideRule = 'right => + pmDontQuote? realOp => realOp + $quotedOpList := [op, :$quotedOpList] + op + symEqual(realOp, "|") => realOp + symEqual(realOp, ":") => realOp + symEqual(realOp, "?") => realOp + op + op + +pfApplication2Sex pf == + $insideApplication: local := true + op := pfOp2Sex pfApplicationOp pf + op := opTran op + op = "->" => + args := pf0TupleParts pfApplicationArg pf + if pfTuple? CAR args then + typeList := [pf2Sex1 arg for arg in pf0TupleParts CAR args] + else + typeList := [pf2Sex1 CAR args] + args := [pf2Sex1 CADR args, :typeList] + ["Mapping", :args] + symEqual(op, ":") and $insideRule = 'left => + ["multiple", pf2Sex pfApplicationArg pf] + symEqual(op, "?") and $insideRule = 'left => + ["optional", pf2Sex pfApplicationArg pf] + args := pfApplicationArg pf + pfTuple? args => + symEqual(op, "|") and $insideRule = 'left => + pfSuchThat2Sex args + argSex := rest pf2Sex1 args + symEqual(op, ">") => + ["<", CADR argSex, CAR argSex] + symEqual(op, ">=") => + ["not", ["<", CAR argSex, CADR argSex]] + symEqual(op, "<=") => + ["not", ["<", CADR argSex, CAR argSex]] +-- symEqual(op, "reduce") and (#argSex) = 2 => +-- ["REDUCE", first argSex, 0, CADR argSex] + symEqual(op, "AND") => + ["and", CAR argSex, CADR argSex] + symEqual(op, "OR") => + ["or", CAR argSex, CADR argSex] + symEqual(op, "Iterate") => + ["iterate"] + symEqual(op, "by") => + ["BY", :argSex] + symEqual(op, "braceFromCurly") => +-- ["brace", ["construct", :argSex]] + argSex is ["SEQ",:.] => argSex + ["SEQ", :argSex] + op is [qt, realOp] and symEqual(qt, "QUOTE") => + ["applyQuote", op, :argSex] + val := hasOptArgs? argSex => [op, :val] + [op, :argSex] + op is [qt, realOp] and symEqual(qt, "QUOTE") => + ["applyQuote", op, pf2Sex1 args] + symEqual(op, "braceFromCurly") => +-- ["brace", ["construct", pf2Sex1 args]] + x := pf2Sex1 args + x is ["SEQ", :.] => x + ["SEQ", x] + symEqual(op, "by") => + ["BY", pf2Sex1 args] + [op, pf2Sex1 args] + +hasOptArgs? argSex == + nonOpt := nil + opt := nil + for arg in argSex repeat + arg is ["OPTARG", lhs, rhs] => + opt := [[lhs, rhs], :opt] + nonOpt := [arg, :nonOpt] + null opt => nil + NCONC (nreverse nonOpt, [["construct", :nreverse opt]]) + +pfDefinition2Sex pf == + $insideApplication => + ["OPTARG", pf2Sex1 CAR pf0DefinitionLhsItems pf, + pf2Sex1 pfDefinitionRhs pf] + idList := [pf2Sex1 x for x in pf0DefinitionLhsItems pf] + #idList ^= 1 => + systemError '"lhs of definition must be a single item in the interpreter" + id := first idList + rhs := pfDefinitionRhs pf + [argList, :body] := pfLambdaTran rhs + ["DEF", (argList = 'id => id; [id, :argList]), :body] + +pfLambdaTran pf == + pfLambda? pf => + argTypeList := nil + argList := nil + for arg in pf0LambdaArgs pf repeat + pfTyped? arg => + argList := [pfCollectArgTran pfTypedId arg, :argList] + pfNothing? pfTypedType arg => + argTypeList := [nil, :argTypeList] + argTypeList := [pf2Sex1 pfTypedType arg, :argTypeList] + systemError '"definition args should be typed" + argList := nreverse argList + retType := + pfNothing? pfLambdaRets pf => nil + pf2Sex1 pfLambdaRets pf + argTypeList := [retType, :nreverse argTypeList] + [argList, :[argTypeList, [nil for arg in argTypeList], + pf2Sex1 pfLambdaBody pf]] + ['id, :['(()), '(()), pf2Sex1 pf]] + +pfLambda2Sex pf == + [argList, :body] := pfLambdaTran pf + ["ADEF", argList, :body] + +pfCollectArgTran pf == + pfCollect? pf => + conds := [pf2Sex1 x for x in pfParts pfCollectIterators pf] + id := pf2Sex1 pfCollectBody pf + conds is [["|", cond]] => + ["|", id, cond] + [id, :conds] + pf2Sex1 pf + +opTran op == + op = $dotdot => "SEGMENT" + op = "[]" => "construct" + op = "{}" => "braceFromCurly" + op = "IS" => "is" + op + +pfSequence2Sex pf == + $insideSEQ:local := true + seq := pfSequence2Sex0 [pf2Sex1 x for x in pf0SequenceArgs pf] + seq is ["SEQ", :ruleList] and ruleList is [["rule", :.], :.] => + ["ruleset", ["construct", :ruleList]] + seq + +pfSequence2Sex0 seqList == + null seqList => "noBranch" + seqTranList := [] + while seqList ^= nil repeat + item := first seqList + item is ["exit", cond, value] => + item := ["IF", cond, value, pfSequence2Sex0 rest seqList] + seqTranList := [item, :seqTranList] + seqList := nil + seqTranList := [item ,:seqTranList] + seqList := rest seqList + #seqTranList = 1 => first seqTranList + ["SEQ", :nreverse seqTranList] + +float2Sex num == + eIndex := SEARCH('"e", num) + mantPart := + eIndex => SUBSEQ(num, 0, eIndex) + num + expPart := (eIndex => READ_-FROM_-STRING SUBSEQ(num, eIndex+1); 0) + dotIndex := SEARCH('".", mantPart) + intPart := + dotIndex => READ_-FROM_-STRING SUBSEQ(mantPart, 0, dotIndex) + READ_-FROM_-STRING mantPart + fracPartString := + dotIndex => SUBSEQ(mantPart, dotIndex+1) + '"0" + bfForm := MAKE_-FLOAT(intPart, READ_-FROM_-STRING fracPartString, + LENGTH fracPartString, expPart) + $useBFasDefault => + [., frac, :exp] := bfForm + [["$elt", intNewFloat(), 'float], frac, exp, 10] + bfForm + +loopIters2Sex iterList == + result := nil + for iter in iterList repeat + sex := pf2Sex1 iter + sex is ['IN, var, ['SEGMENT, i, ["BY", incr]]] => + result := [['STEP, var, i, incr], :result] + sex is ['IN, var, ["BY", ['SEGMENT, i, j], incr]] => + result := [['STEP, var, i, incr, j], :result] + sex is ['IN, var, ['SEGMENT, i, j]] => + result := [['STEP, var, i, 1, j], :result] + result := [sex, :result] + nreverse result + +pfCollect2Sex pf == + sex := ["COLLECT", :loopIters2Sex pfParts pfCollectIterators pf, + pf2Sex1 pfCollectBody pf] + sex is ["COLLECT", ["|", cond], var] and SYMBOLP var => + ["|", var, cond] + sex + +pfRule2Sex pf == + $quotedOpList:local := nil + $predicateList:local := nil + $multiVarPredicateList:local := nil + lhs := pfLhsRule2Sex pfRuleLhsItems pf + rhs := pfRhsRule2Sex pfRuleRhs pf + lhs := ruleLhsTran lhs + rulePredicateTran + $quotedOpList => ["rule", lhs, rhs, ["construct", :$quotedOpList]] + ["rule", lhs, rhs] + + +ruleLhsTran ruleLhs == + for pred in $predicateList repeat + [name, predLhs, :predRhs] := pred + vars := patternVarsOf predRhs + CDR vars => -- if there is more than one patternVariable + ruleLhs := NSUBST(predLhs, name, ruleLhs) + $multiVarPredicateList := [pred, :$multiVarPredicateList] + predicate := + [., var] := predLhs + ["suchThat", predLhs, ["ADEF", [var], + '((Boolean) (Expression (Integer))), '(() ()), predRhs]] + ruleLhs := NSUBST(predicate, name, ruleLhs) + ruleLhs + +rulePredicateTran rule == + null $multiVarPredicateList => rule + varList := patternVarsOf [rhs for [.,.,:rhs] in $multiVarPredicateList] + predBody := + CDR $multiVarPredicateList => + ['AND, :[:pvarPredTran(rhs, varList) for [.,.,:rhs] in + $multiVarPredicateList]] + [[.,.,:rhs],:.] := $multiVarPredicateList + pvarPredTran(rhs, varList) + ['suchThat, rule, + ['construct, :[["QUOTE", var] for var in varList]], + ['ADEF, '(predicateVariable), + '((Boolean) (List (Expression (Integer)))), '(() ()), + predBody]] + +pvarPredTran(rhs, varList) == + for var in varList for i in 1.. repeat + rhs := NSUBST(['elt, 'predicateVariable, i], var, rhs) + rhs + +patternVarsOf expr == + patternVarsOf1(expr, nil) + +patternVarsOf1(expr, varList) == + NULL expr => varList + ATOM expr => + null SYMBOLP expr => varList + SymMemQ(expr, varList) => varList + [expr, :varList] + expr is [op, :argl] => + for arg in argl repeat + varList := patternVarsOf1(arg, varList) + varList + varList + +pfLhsRule2Sex lhs == + $insideRule: local := 'left + pf2Sex1 lhs + + +pfRhsRule2Sex rhs == + $insideRule: local := 'right + pf2Sex1 rhs + +pfSuchThat2Sex args == + name := GENTEMP() + argList := pf0TupleParts args + lhsSex := pf2Sex1 CAR argList + rhsSex := pf2Sex CADR argList + $predicateList := [[name, lhsSex, :rhsSex], :$predicateList] + name + + + + diff --git a/src/interp/pf2sex.boot.pamphlet b/src/interp/pf2sex.boot.pamphlet deleted file mode 100644 index a5ea9b6e..00000000 --- a/src/interp/pf2sex.boot.pamphlet +++ /dev/null @@ -1,526 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp pf2sex.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{Changes} -In the function [[float2Sex]] we need to special case the return value -if the global variable [[$useBFasDefault]] is set to true. This variable -allows ``big'' floating point values. - -The change can be seen from this email from Greg Vanuxem: -\begin{verbatim} -Attached is the patch (pf2sex.patch) that allows the use -of DoubleFloat by default in the interpreter. Test it. - -(1) -> 1.7+7.2 - - (1) 8.9 - Type: Float -(2) -> 1.7-7.2 - - (2) - 5.5 - Type: Float -(3) -> -1.7-7.2 - - (3) - 8.9 - Type: Float -(4) -> )boot $useBFasDefault:=false - -(SPADLET |$useBFasDefault| NIL) -Value = NIL - -(4) -> 1.7+7.2 - - (4) 8.9000000000000004 - Type: DoubleFloat -(5) -> 1.7-7.2 - - (5) - 5.5 - Type: DoubleFloat -(6) -> -1.7-7.2 - - (6) - 8.9000000000000004 - Type: DoubleFloat - - - -\end{verbatim} -\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" - -$dotdot := INTERN('"..", '"BOOT") -$specificMsgTags := nil - --- Pftree to s-expression translation. Used to interface the new parser --- technology to the interpreter. The input is a parseTree and the --- output is an old-parser-style s-expression - -pf2Sex pf == - intUnsetQuiet() - $insideRule:local := false - $insideApplication: local := false - $insideSEQ: local := false - pf2Sex1 pf - -pf2Sex1 pf == - pfNothing? pf => - "noBranch" - pfSymbol? pf => - $insideRule = 'left => - s := pfSymbolSymbol pf - ["constant", ["QUOTE", s]] - ["QUOTE", pfSymbolSymbol pf] - pfLiteral? pf => - pfLiteral2Sex pf - pfId? pf => - $insideRule => - s := pfIdSymbol pf - SymMemQ(s, '(%pi %e %i)) => s - ["QUOTE", s] - pfIdSymbol pf - pfApplication? pf => - pfApplication2Sex pf - pfTuple? pf => - ["Tuple", :[pf2Sex1 x for x in pf0TupleParts pf]] - pfIf? pf => - ['IF, pf2Sex1 pfIfCond pf, pf2Sex1 pfIfThen pf, pf2Sex1 pfIfElse pf] - pfTagged? pf => - tag := pfTaggedTag pf - tagPart := - pfTuple? tag => - ['Tuple, :[pf2Sex1 arg for arg in pf0TupleParts tag]] - pf2Sex1 tag - [":", tagPart, pf2Sex1 pfTaggedExpr pf] - pfCoerceto? pf => - ["::", pf2Sex1 pfCoercetoExpr pf, pf2Sex1 pfCoercetoType pf] - pfPretend? pf => - ["pretend", pf2Sex1 pfPretendExpr pf, pf2Sex1 pfPretendType pf] - pfFromdom? pf => - op := opTran pf2Sex1 pfFromdomWhat pf --- if op = "braceFromCurly" then op := "brace" - if op = "braceFromCurly" then op := "SEQ" - ["$elt", pf2Sex1 pfFromdomDomain pf, op] - pfSequence? pf => - pfSequence2Sex pf - pfExit? pf => - $insideSEQ => ["exit", pf2Sex1 pfExitCond pf, pf2Sex1 pfExitExpr pf] - ["IF", pf2Sex1 pfExitCond pf, pf2Sex1 pfExitExpr pf, "noBranch"] - pfLoop? pf => - ["REPEAT", :loopIters2Sex pf0LoopIterators pf] - pfCollect? pf => - pfCollect2Sex pf - pfForin? pf => - ["IN", :[pf2Sex1 x for x in pf0ForinLhs pf], pf2Sex1 pfForinWhole pf] - pfWhile? pf => - ["WHILE", pf2Sex1 pfWhileCond pf] - pfSuchthat? pf => - $insideRule = 'left => - keyedSystemError('"S2GE0017", ['"pf2Sex1: pfSuchThat"]) - ["|", pf2Sex1 pfSuchthatCond pf] - pfDo? pf => - pf2Sex1 pfDoBody pf - pfTyped? pf => - type := pfTypedType pf - pfNothing? type => pf2Sex1 pfTypedId pf - [":", pf2Sex1 pfTypedId pf, pf2Sex1 pfTypedType pf] - pfAssign? pf => - idList := [pf2Sex1 x for x in pf0AssignLhsItems pf] - if #idList ^= 1 then idList := ['Tuple, :idList] - else idList := first idList - ["LET", idList, pf2Sex1 pfAssignRhs pf] - pfDefinition? pf => - pfDefinition2Sex pf - pfLambda? pf => - pfLambda2Sex pf - pfMLambda? pf => - "/throwAway" - pfRestrict? pf => - ["@", pf2Sex1 pfRestrictExpr pf, pf2Sex1 pfRestrictType pf] - pfFree? pf => - ['free, :[pf2Sex1 item for item in pf0FreeItems pf]] - pfLocal? pf => - ['local, :[pf2Sex1 item for item in pf0LocalItems pf]] - pfWrong? pf => - spadThrow() - pfAnd? pf => - ["and", pf2Sex1 pfAndLeft pf, pf2Sex1 pfAndRight pf] - pfOr? pf => - ["or", pf2Sex1 pfOrLeft pf, pf2Sex1 pfOrRight pf] - pfNot? pf => - ["not", pf2Sex1 pfNotArg pf] - pfNovalue? pf => - intSetQuiet() - ["SEQ", pf2Sex1 pfNovalueExpr pf] - pfRule? pf => - pfRule2Sex pf - pfBreak? pf => - ["break", pfBreakFrom pf] - pfMacro? pf => - "/throwAway" - pfReturn? pf => - ["return", pf2Sex1 pfReturnExpr pf] - pfIterate? pf => - ["iterate"] - pfWhere? pf => - args := [pf2Sex1 p for p in pf0WhereContext pf] - #args = 1 => - ["where", pf2Sex1 pfWhereExpr pf, :args] - ["where", pf2Sex1 pfWhereExpr pf, ["SEQ", :args]] - - -- under strange circumstances/piling, system commands can wind - -- up in expressions. This just passes it through as a string for - -- the user to figure out what happened. - pfAbSynOp(pf) = "command" => tokPart(pf) - - keyedSystemError('"S2GE0017", ['"pf2Sex1"]) - -pfLiteral2Sex pf == - type := pfLiteralClass pf - type = 'integer => - READ_-FROM_-STRING pfLiteralString pf - type = 'string or type = 'char => - pfLiteralString pf - type = 'float => - float2Sex pfLiteralString pf - type = 'symbol => - $insideRule => - s := pfSymbolSymbol pf - ["QUOTE", s] - pfSymbolSymbol pf - type = 'expression => - ["QUOTE", pfLeafToken pf] - keyedSystemError('"S2GE0017", ['"pfLiteral2Sex: unexpected form"]) - -symEqual(sym, sym2) == EQ(sym, sym2) - -SymMemQ(sy, l) == MEMQ(sy, l) - -pmDontQuote? sy == - SymMemQ(sy, '(_+ _- _* _*_* _^ _/ log exp pi sqrt ei li erf ci si dilog _ - sin cos tan cot sec csc asin acos atan acot asec acsc _ - sinh cosh tanh coth sech csch asinh acosh atanh acoth asech acsc)) - -pfOp2Sex pf == - alreadyQuoted := pfSymbol? pf - op := pf2Sex1 pf - op is ["QUOTE", realOp] => - $insideRule = 'left => realOp - $insideRule = 'right => - pmDontQuote? realOp => realOp - $quotedOpList := [op, :$quotedOpList] - op - symEqual(realOp, "|") => realOp - symEqual(realOp, ":") => realOp - symEqual(realOp, "?") => realOp - op - op - -pfApplication2Sex pf == - $insideApplication: local := true - op := pfOp2Sex pfApplicationOp pf - op := opTran op - op = "->" => - args := pf0TupleParts pfApplicationArg pf - if pfTuple? CAR args then - typeList := [pf2Sex1 arg for arg in pf0TupleParts CAR args] - else - typeList := [pf2Sex1 CAR args] - args := [pf2Sex1 CADR args, :typeList] - ["Mapping", :args] - symEqual(op, ":") and $insideRule = 'left => - ["multiple", pf2Sex pfApplicationArg pf] - symEqual(op, "?") and $insideRule = 'left => - ["optional", pf2Sex pfApplicationArg pf] - args := pfApplicationArg pf - pfTuple? args => - symEqual(op, "|") and $insideRule = 'left => - pfSuchThat2Sex args - argSex := rest pf2Sex1 args - symEqual(op, ">") => - ["<", CADR argSex, CAR argSex] - symEqual(op, ">=") => - ["not", ["<", CAR argSex, CADR argSex]] - symEqual(op, "<=") => - ["not", ["<", CADR argSex, CAR argSex]] --- symEqual(op, "reduce") and (#argSex) = 2 => --- ["REDUCE", first argSex, 0, CADR argSex] - symEqual(op, "AND") => - ["and", CAR argSex, CADR argSex] - symEqual(op, "OR") => - ["or", CAR argSex, CADR argSex] - symEqual(op, "Iterate") => - ["iterate"] - symEqual(op, "by") => - ["BY", :argSex] - symEqual(op, "braceFromCurly") => --- ["brace", ["construct", :argSex]] - argSex is ["SEQ",:.] => argSex - ["SEQ", :argSex] - op is [qt, realOp] and symEqual(qt, "QUOTE") => - ["applyQuote", op, :argSex] - val := hasOptArgs? argSex => [op, :val] - [op, :argSex] - op is [qt, realOp] and symEqual(qt, "QUOTE") => - ["applyQuote", op, pf2Sex1 args] - symEqual(op, "braceFromCurly") => --- ["brace", ["construct", pf2Sex1 args]] - x := pf2Sex1 args - x is ["SEQ", :.] => x - ["SEQ", x] - symEqual(op, "by") => - ["BY", pf2Sex1 args] - [op, pf2Sex1 args] - -hasOptArgs? argSex == - nonOpt := nil - opt := nil - for arg in argSex repeat - arg is ["OPTARG", lhs, rhs] => - opt := [[lhs, rhs], :opt] - nonOpt := [arg, :nonOpt] - null opt => nil - NCONC (nreverse nonOpt, [["construct", :nreverse opt]]) - -pfDefinition2Sex pf == - $insideApplication => - ["OPTARG", pf2Sex1 CAR pf0DefinitionLhsItems pf, - pf2Sex1 pfDefinitionRhs pf] - idList := [pf2Sex1 x for x in pf0DefinitionLhsItems pf] - #idList ^= 1 => - systemError '"lhs of definition must be a single item in the interpreter" - id := first idList - rhs := pfDefinitionRhs pf - [argList, :body] := pfLambdaTran rhs - ["DEF", (argList = 'id => id; [id, :argList]), :body] - -pfLambdaTran pf == - pfLambda? pf => - argTypeList := nil - argList := nil - for arg in pf0LambdaArgs pf repeat - pfTyped? arg => - argList := [pfCollectArgTran pfTypedId arg, :argList] - pfNothing? pfTypedType arg => - argTypeList := [nil, :argTypeList] - argTypeList := [pf2Sex1 pfTypedType arg, :argTypeList] - systemError '"definition args should be typed" - argList := nreverse argList - retType := - pfNothing? pfLambdaRets pf => nil - pf2Sex1 pfLambdaRets pf - argTypeList := [retType, :nreverse argTypeList] - [argList, :[argTypeList, [nil for arg in argTypeList], - pf2Sex1 pfLambdaBody pf]] - ['id, :['(()), '(()), pf2Sex1 pf]] - -pfLambda2Sex pf == - [argList, :body] := pfLambdaTran pf - ["ADEF", argList, :body] - -pfCollectArgTran pf == - pfCollect? pf => - conds := [pf2Sex1 x for x in pfParts pfCollectIterators pf] - id := pf2Sex1 pfCollectBody pf - conds is [["|", cond]] => - ["|", id, cond] - [id, :conds] - pf2Sex1 pf - -opTran op == - op = $dotdot => "SEGMENT" - op = "[]" => "construct" - op = "{}" => "braceFromCurly" - op = "IS" => "is" - op - -pfSequence2Sex pf == - $insideSEQ:local := true - seq := pfSequence2Sex0 [pf2Sex1 x for x in pf0SequenceArgs pf] - seq is ["SEQ", :ruleList] and ruleList is [["rule", :.], :.] => - ["ruleset", ["construct", :ruleList]] - seq - -pfSequence2Sex0 seqList == - null seqList => "noBranch" - seqTranList := [] - while seqList ^= nil repeat - item := first seqList - item is ["exit", cond, value] => - item := ["IF", cond, value, pfSequence2Sex0 rest seqList] - seqTranList := [item, :seqTranList] - seqList := nil - seqTranList := [item ,:seqTranList] - seqList := rest seqList - #seqTranList = 1 => first seqTranList - ["SEQ", :nreverse seqTranList] - -float2Sex num == - eIndex := SEARCH('"e", num) - mantPart := - eIndex => SUBSEQ(num, 0, eIndex) - num - expPart := (eIndex => READ_-FROM_-STRING SUBSEQ(num, eIndex+1); 0) - dotIndex := SEARCH('".", mantPart) - intPart := - dotIndex => READ_-FROM_-STRING SUBSEQ(mantPart, 0, dotIndex) - READ_-FROM_-STRING mantPart - fracPartString := - dotIndex => SUBSEQ(mantPart, dotIndex+1) - '"0" - bfForm := MAKE_-FLOAT(intPart, READ_-FROM_-STRING fracPartString, - LENGTH fracPartString, expPart) - $useBFasDefault => - [., frac, :exp] := bfForm - [["$elt", intNewFloat(), 'float], frac, exp, 10] - bfForm - -loopIters2Sex iterList == - result := nil - for iter in iterList repeat - sex := pf2Sex1 iter - sex is ['IN, var, ['SEGMENT, i, ["BY", incr]]] => - result := [['STEP, var, i, incr], :result] - sex is ['IN, var, ["BY", ['SEGMENT, i, j], incr]] => - result := [['STEP, var, i, incr, j], :result] - sex is ['IN, var, ['SEGMENT, i, j]] => - result := [['STEP, var, i, 1, j], :result] - result := [sex, :result] - nreverse result - -pfCollect2Sex pf == - sex := ["COLLECT", :loopIters2Sex pfParts pfCollectIterators pf, - pf2Sex1 pfCollectBody pf] - sex is ["COLLECT", ["|", cond], var] and SYMBOLP var => - ["|", var, cond] - sex - -pfRule2Sex pf == - $quotedOpList:local := nil - $predicateList:local := nil - $multiVarPredicateList:local := nil - lhs := pfLhsRule2Sex pfRuleLhsItems pf - rhs := pfRhsRule2Sex pfRuleRhs pf - lhs := ruleLhsTran lhs - rulePredicateTran - $quotedOpList => ["rule", lhs, rhs, ["construct", :$quotedOpList]] - ["rule", lhs, rhs] - - -ruleLhsTran ruleLhs == - for pred in $predicateList repeat - [name, predLhs, :predRhs] := pred - vars := patternVarsOf predRhs - CDR vars => -- if there is more than one patternVariable - ruleLhs := NSUBST(predLhs, name, ruleLhs) - $multiVarPredicateList := [pred, :$multiVarPredicateList] - predicate := - [., var] := predLhs - ["suchThat", predLhs, ["ADEF", [var], - '((Boolean) (Expression (Integer))), '(() ()), predRhs]] - ruleLhs := NSUBST(predicate, name, ruleLhs) - ruleLhs - -rulePredicateTran rule == - null $multiVarPredicateList => rule - varList := patternVarsOf [rhs for [.,.,:rhs] in $multiVarPredicateList] - predBody := - CDR $multiVarPredicateList => - ['AND, :[:pvarPredTran(rhs, varList) for [.,.,:rhs] in - $multiVarPredicateList]] - [[.,.,:rhs],:.] := $multiVarPredicateList - pvarPredTran(rhs, varList) - ['suchThat, rule, - ['construct, :[["QUOTE", var] for var in varList]], - ['ADEF, '(predicateVariable), - '((Boolean) (List (Expression (Integer)))), '(() ()), - predBody]] - -pvarPredTran(rhs, varList) == - for var in varList for i in 1.. repeat - rhs := NSUBST(['elt, 'predicateVariable, i], var, rhs) - rhs - -patternVarsOf expr == - patternVarsOf1(expr, nil) - -patternVarsOf1(expr, varList) == - NULL expr => varList - ATOM expr => - null SYMBOLP expr => varList - SymMemQ(expr, varList) => varList - [expr, :varList] - expr is [op, :argl] => - for arg in argl repeat - varList := patternVarsOf1(arg, varList) - varList - varList - -pfLhsRule2Sex lhs == - $insideRule: local := 'left - pf2Sex1 lhs - - -pfRhsRule2Sex rhs == - $insideRule: local := 'right - pf2Sex1 rhs - -pfSuchThat2Sex args == - name := GENTEMP() - argList := pf0TupleParts args - lhsSex := pf2Sex1 CAR argList - rhsSex := pf2Sex CADR argList - $predicateList := [[name, lhsSex, :rhsSex], :$predicateList] - name - - - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/pile.boot b/src/interp/pile.boot index 9fc3f0c7..9742602e 100644 --- a/src/interp/pile.boot +++ b/src/interp/pile.boot @@ -1,5 +1,7 @@ -- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are diff --git a/src/interp/profile.boot b/src/interp/profile.boot new file mode 100644 index 00000000..bc0916ac --- /dev/null +++ b/src/interp/profile.boot @@ -0,0 +1,94 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- 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. + + +import '"macros" +)package "BOOT" + +--$profileCompiler := true +$profileAlist := nil + +profileWrite() == --called from finalizeLisplib + outStream := MAKE_-OUTSTREAM CONCAT(LIBSTREAM_-DIRNAME $libFile,'"/info") + SETQ(_*PRINT_-PRETTY_*, true) + PRINT_-FULL(profileTran $profileAlist,outStream) + SHUT outStream + +profileTran alist == + $profileHash := MAKE_-HASH_-TABLE() + for [opSig,:info] in alist repeat + op := opOf opSig + sig := KAR KDR opSig + HPUT($profileHash,op,[[sig,:info],:HGET($profileHash,op)]) + [[key,:HGET($profileHash,key)] for key in mySort HKEYS $profileHash] + +profileRecord(label,name,info) == --name: info is var: type or op: sig +--$profileAlist is ((op . alist1) ...) where +-- alist1 is ((label . alist2) ...) where +-- alist2 is ((name . info) ...) + if $insideCapsuleFunctionIfTrue then + op := $op + argl := CDR $form + opSig := [$op,$signatureOfForm] + else + op := 'constructor + argl := nil + opSig := [op] + if label = 'locals and MEMQ(name,argl) then label := 'arguments + alist1 := LASSOC(opSig,$profileAlist) + alist2 := LASSOC(label,alist1) + newAlist2 := insertAlist(name,info,alist2) + newAlist1 := insertAlist(label,newAlist2,alist1) + $profileAlist := insertAlist(opSig,newAlist1,$profileAlist) + $profileAlist + +profileDisplay() == + profileDisplayOp('constructor,LASSOC('constructor,$profileAlist) ) + for [op,:alist1] in $profileAlist | op ^= 'constructor repeat + profileDisplayOp(op,alist1) + +profileDisplayOp(op,alist1) == + sayBrightly op + if LASSOC('arguments,alist1) then + sayBrightly '" arguments" + for [x,:t] in MSORT LASSOC('arguments,alist1) repeat + sayBrightly concat('" ",x,": ",prefix2String t) + if LASSOC('locals,alist1) then + sayBrightly '" locals" + for [x,:t] in MSORT LASSOC('locals,alist1) repeat + sayBrightly concat('" ",x,": ",prefix2String t) + for [con,:alist2] in alist1 | not MEMQ(con,'(locals arguments)) repeat + sayBrightly concat('" ",prefix2String con) + for [op1,:sig] in MSORT alist2 repeat + sayBrightly ['" ",:formatOpSignature(op1,sig)] + diff --git a/src/interp/profile.boot.pamphlet b/src/interp/profile.boot.pamphlet deleted file mode 100644 index f6d858d9..00000000 --- a/src/interp/profile.boot.pamphlet +++ /dev/null @@ -1,114 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp profile.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\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. - -@ -<<*>>= -<> - -import '"macros" -)package "BOOT" - ---$profileCompiler := true -$profileAlist := nil - -profileWrite() == --called from finalizeLisplib - outStream := MAKE_-OUTSTREAM CONCAT(LIBSTREAM_-DIRNAME $libFile,'"/info") - SETQ(_*PRINT_-PRETTY_*, true) - PRINT_-FULL(profileTran $profileAlist,outStream) - SHUT outStream - -profileTran alist == - $profileHash := MAKE_-HASH_-TABLE() - for [opSig,:info] in alist repeat - op := opOf opSig - sig := KAR KDR opSig - HPUT($profileHash,op,[[sig,:info],:HGET($profileHash,op)]) - [[key,:HGET($profileHash,key)] for key in mySort HKEYS $profileHash] - -profileRecord(label,name,info) == --name: info is var: type or op: sig ---$profileAlist is ((op . alist1) ...) where --- alist1 is ((label . alist2) ...) where --- alist2 is ((name . info) ...) - if $insideCapsuleFunctionIfTrue then - op := $op - argl := CDR $form - opSig := [$op,$signatureOfForm] - else - op := 'constructor - argl := nil - opSig := [op] - if label = 'locals and MEMQ(name,argl) then label := 'arguments - alist1 := LASSOC(opSig,$profileAlist) - alist2 := LASSOC(label,alist1) - newAlist2 := insertAlist(name,info,alist2) - newAlist1 := insertAlist(label,newAlist2,alist1) - $profileAlist := insertAlist(opSig,newAlist1,$profileAlist) - $profileAlist - -profileDisplay() == - profileDisplayOp('constructor,LASSOC('constructor,$profileAlist) ) - for [op,:alist1] in $profileAlist | op ^= 'constructor repeat - profileDisplayOp(op,alist1) - -profileDisplayOp(op,alist1) == - sayBrightly op - if LASSOC('arguments,alist1) then - sayBrightly '" arguments" - for [x,:t] in MSORT LASSOC('arguments,alist1) repeat - sayBrightly concat('" ",x,": ",prefix2String t) - if LASSOC('locals,alist1) then - sayBrightly '" locals" - for [x,:t] in MSORT LASSOC('locals,alist1) repeat - sayBrightly concat('" ",x,": ",prefix2String t) - for [con,:alist2] in alist1 | not MEMQ(con,'(locals arguments)) repeat - sayBrightly concat('" ",prefix2String con) - for [op1,:sig] in MSORT alist2 repeat - sayBrightly ['" ",:formatOpSignature(op1,sig)] - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/pspad1.boot b/src/interp/pspad1.boot new file mode 100644 index 00000000..ce580b14 --- /dev/null +++ b/src/interp/pspad1.boot @@ -0,0 +1,743 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- 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" + +$escapeWords := ["always", "assert", "but", "define", + "delay", "do", "except", "export", "extend", "fix", "fluid", + "from", "generate", "goto", "import", "inline", "never", "select", + "try", "yield"] +$pileStyle := false +$commentIndentation := 8 +$braceIndentation := 8 +$doNotResetMarginIfTrue := true +$marginStack := nil +$numberOfSpills := 0 +$lineFragmentBuffer:= nil +$pspadRelationAlist := '((_= . _~_=) (_< . _>_=) (_<_= . _>)(_~_= . _=)(_>_= . _<) (_> . _<_=)) +$lineBuffer := nil +$formatForcePren := nil +$underScore := char ('__) +$rightBraceFlag := nil +$semicolonFlag := nil +$newLineWritten := nil +$comments := nil +$noColonDeclaration := false +$renameAlist := '( + (SmallInteger . SingleInteger) + (SmallFloat . DoubleFloat) + (Void . _(_)) + (xquo . exquo) + (setelt . set_!) + (_$ . _%) + (_$_$ . _$) + (_*_* . _^) + (_^_= . _~_=) + (_^ . _~)) + +--$opRenameAlist := '( +-- (and . AND) +-- (or . OR) +-- (not . NOT)) + + +--====================================================================== +-- Main Translator Function +--====================================================================== +--% lisp-fragment to boot-fragment functions +lisp2Boot x == + --entry function + $fieldNames := nil + $pilesAreOkHere: local:= true + $commentsToPrint: local:= nil + $lineBuffer: local + $braceStack: local := nil + $marginStack: local:= [0] + --$autoLine is true except when inside a try---if true, lines are allowed to break + $autoLine:= true + $lineFragmentBuffer:= nil + $bc:=0 --brace count + $m:= 0 + $c:= $m + $numberOfSpills:= 0 + $lineLength:= 80 + format x + formatOutput REVERSE $lineFragmentBuffer + [fragmentsToLine y for y in REVERSE $lineBuffer] + +fragmentsToLine fragments == + string:= lispStringList2String fragments + line:= GETSTR 240 + for i in 0..MAXINDEX string repeat line:= SUFFIX(string.i,line) + line + +lispStringList2String x == + null x => '"" + atom x => STRINGIMAGE x + CDR x => APPLY(function STRCONC,MAPCAR(function lispStringList2String,x)) + lispStringList2String CAR x + +--% routines for buffer and margin adjustment + +formatOutput x == + for [currentColumn,start,end,stack] in REVERSE $commentsToPrint repeat + startY:= rest start + for [loc,comment] in stack repeat + commentY:= rest loc + gap:= startY-commentY + gap>0 => before:= [[commentY,first loc,gap,comment],:before] + gap=0 => same:= [[startY,1,gap,comment],:same] + true => after:= [[startY,first loc,-gap,comment],:after] + if before then putOut before + if same then + [y,:extraLines]:= "append"/[mkCommentLines u for u in orderList same] + line:= fragmentsToLine x + x:= + #line+#y>$lineLength => + (y:= STRCONC(nBlanks $m,y); extraLines:= [y,:extraLines]; x) + [line,y] + consLineBuffer x + for y in extraLines repeat consLineBuffer LIST y + if after then putOut after + $commentsToPrint:= nil + +consLineBuffer x == $lineBuffer := [x,:$lineBuffer] + +putOut x == + eject ("min"/[gap for [.,.,gap,:.] in x]) + for u in orderList x repeat addComment u + +eject n == for i in 2..n repeat consLineBuffer nil + +addComment u == + for x in mkCommentLines u repeat consLineBuffer LIST x + +mkCommentLines [.,n,.,s] == + lines:= breakComments s + lines1:= [fragmentsToLine [nBlanks n,"_{",first lines],:rest lines] + [:l,last]:= lines1 + [:l,fragmentsToLine [last,"_}"]] + +breakComments s == + n:= containsString(s,PNAME "ENDOFLINECHR") => + #s>n+12 => [SUBSTRING(s,0,n),:breakComments SUBSTRING(s,n+12,NIL)] + LIST SUBSTRING(s,0,n) + LIST s + +containsString(x,y) == + --if string x contains string y, return start index + for i in 0..MAXINDEX x-MAXINDEX y repeat + and/[x.(i+j)=y.j for j in 0..MAXINDEX y] => return i + +--====================================================================== +-- Character/String Buffer Functions +--====================================================================== +consBuffer item == + if item = '"failed" then item := 'failed + n:= + STRINGP item => 2+#item + IDENTP item => #PNAME item + #STRINGIMAGE item + columnsLeft:= $lineLength-$c + if columnsLeft <= 0 and isCloseDelimiter item then $lineLength := $lineLength + 2 + columnsLeft:= $lineLength-$c + --cheat for semicolons, strings, and delimiters: they are NEVER too long + not isSpecialBufferItem item and (n>columnsLeft or columnsLeft < 0) => + $autoLine => + --is true except within try + formatOutput REVERSE $lineFragmentBuffer + $c:= REMAINDER($m+2*($numberOfSpills:= $numberOfSpills+1), $lineLength) + $lineFragmentBuffer:= LIST nBlanks $c + consBuffer item + nil + $lineFragmentBuffer:= + ^item or IDENTP item => [PNAME item,:$lineFragmentBuffer] + NUMBERP item or CHARP item => [STRINGIMAGE item,:$lineFragmentBuffer] + STRINGP item => ["_"",string2PrintImage item,"_"",:$lineFragmentBuffer] + sayBrightly ['"Unexpected line buffer item: ", STRINGIMAGE item] + $lineFragmentBuffer + $rightBraceFlag := item = "}" + $semicolonFlag := item = "; " --prevents consecutive semicolons + $c:= $c+n + +isSpecialBufferItem item == + item = "; " or STRINGP item => true + false + +isCloseDelimiter item == EQ(item,")") or EQ(item,"]") or EQ(item,"}") + +--====================================================================== +-- Formatting/Line Control Functions +--====================================================================== +newLine() == + null $autoLine => nil + $newLineWritten := true + formatOutput REVERSE $lineFragmentBuffer + $lineFragmentBuffer:= LIST nBlanks $m + $c:= $m + +optNewLine() == + $newLineWritten => newLine() + $c + +spillLine() == + null $autoLine => nil + formatOutput REVERSE $lineFragmentBuffer + $c:= $m+2*($numberOfSpills:= $numberOfSpills+1) + $lineFragmentBuffer:= LIST nBlanks $c + $c + +indent() == + $m:= $m+2*($numberOfSpills+1) + $marginStack:= [$m,:$marginStack] + $numberOfSpills:= 0 + $m + +undent() == +-- $doNotResetMarginIfTrue=true => +-- pp '"hoho" +-- $c + $marginStack is [m,:r] => + $marginStack := r + $m := m + 0 + +spill(fn,a) == + u := try FUNCALL(fn,a) => u + (nearMargin() or spillLine()) and FUNCALL(fn,a) + +formatSpill(fn,a) == + u := try FUNCALL(fn,a) => u + v := (stay:= nearMargin() or indent() and newLine()) and FUNCALL(fn,a) + w := stay or undent() + v and w + +formatSpill2(fn,f,a) == + u := try FUNCALL(fn,f,a) => u + v := (stay:= nearMargin() or indent() and newLine()) and FUNCALL(fn,f,a) + w := stay or undent() + v and w + +nearMargin() == + $c=$m or $c=$m+1 => $c + +--====================================================================== +-- Main Formatting Functions +--====================================================================== +format(x,:options) == + oldC:= $c + qualification := IFCAR options + newCOrNil:= + x is [op,:argl] => + if op = 'return then argl := rest argl + n := #argl + op is ['elt,y,"construct"] => formatDollar(y,'construct,argl) + op is ['elt,name,p] and UPPER_-CASE_-P (STRINGIMAGE opOf name).0 => + formatDollar(name,p,argl) + op = 'elt and UPPER_-CASE_-P (STRINGIMAGE opOf CAR argl).0 => + formatDollar1(CAR argl,CADR argl) + fn:= GETL(op,"PSPAD") => formatFn(fn,x,$m,$c) + if MEMQ(op,'(AND OR NOT)) then op:= DOWNCASE op + n=1 and GETL(op,'Nud) and (lbp:= formatOpBindingPower(op,"Nud","left")) => + formatPrefix(op,first argl,lbp,formatOpBindingPower(op,"Nud","right"),qualification) + n=2 and (op = '_$ or getOp(op,'Led)) and (lbp:= formatOpBindingPower(op,"Led","left")) => + formatInfix(op,argl,lbp,formatOpBindingPower(op,"Led","right"),qualification) + formatForm x + formatAtom x + null newCOrNil => ($c:= oldC; nil) + null FIXP newCOrNil => error() + $c:= newCOrNil + + +getOp(op,kind) == + kind = 'Led => + MEMQ(op,'(_div _exquo)) => nil + GET(op,'Led) + GET(op,'Nud) + +formatDollar(name,p,argl) == + name := markMacroTran name + n := #argl + kind := (n=1 => "Nud"; "Led") + IDENTP name and GETL(p,kind) => format([p,:argl],name) + formatForcePren [p,:argl] and + (try (format "$$" and formatForcePren name) + or (indent() and format "$__" and formatForcePren name and undent())) + +formatMacroCheck name == + ATOM name => name + u := or/[x for [x,:y] in $globalMacroStack | y = name] => u + u := or/[x for [x,:y] in $localMacroStack | y = name] => u + [op,:argl] := name + MEMQ(op,'(Record Union)) => + pp ['"Cannot find: ",name] + name + [op,:[formatMacroCheck x for x in argl]] + +formatDOLLAR ['DOLLAR,x,y] == formatDollar1(y, x) + +formatDollar1(name,arg) == + id := + IDENTP name => name + name is [p] and GETL(p,'NILADIC) => p + name + format arg and format "$$" and formatForcePren id + + +formatForcePren x == + $formatForcePren: local := true + format x + +formatAtom(x,:options) == + if u := LASSOC(x,$renameAlist) then x := u + null x or isIdentifier x => + if MEMQ(x,$escapeWords) then + consBuffer $underScore + consBuffer ident2PrintImage PNAME x + consBuffer x + +formatFn(fn,x,$m,$c) == FUNCALL(fn,x) + +formatFree(['free,:u]) == + format 'free and format " " and formatComma u + +formatUnion(['Union,:r]) == + $count : local := 0 + formatFormNoColonDecl formatTestForPartial ['Union,:[fn x for x in r]] where fn x == + x is [":",y,'Branch] => fn STRINGIMAGE y + STRINGP x => [":", INTERN x, ['Enumeration,x]] + x is [":",:.] => x + tag := INTERN STRCONC("value",STRINGIMAGE ($count := $count + 1)) + [":", tag, x] + +formatTestForPartial u == + u is ['Union,a,b] and b is [":","failed",:.] and a is [":",.,S] => + ['Partial, S] + u + +formatEnumeration(y is ['Enumeration,:r]) == + r is [x] => format "'" and format INTERN STRINGIMAGE x and format "'" + formatForm y + +formatRecord(u) == formatFormNoColonDecl u + +formatFormNoColonDecl u == + $noColonDeclaration: local := true + formatForm u + +formatElt(u) == + u is ["elt",a,b] => formatApplication rest u + formatForm u + +formatForm (u) == + [op,:argl] := u + if MEMQ(op, '(Record Union)) then + $fieldNames := union(getFieldNames argl,$fieldNames) + MEMQ(op,'((QUOTE T) true)) => format "true" + MEMQ(op,'(false nil)) => format op + u='(Zero) => format 0 + u='(One) => format 1 + 1=#argl => formatApplication u + formatFunctionCall u + +formatFunctionCall u == + $pilesAreOkHere: local + spill("formatFunctionCall1",u) + +formatFunctionCall1 [op,:argl] == +--null argl and getConstructorProperty(op,'niladic) => formatOp op + null argl => + GETL(op,'NILADIC) => formatOp op + formatOp op and format "()" + formatOp op and formatFunctionCallTail argl + +formatFunctionCallTail argl == format "_(" and formatComma argl and format "_)" + +formatComma argl == + format first argl and (and/[format "," and formatCut x for x in rest argl]) and $c + +formatOp op == + atom op => formatAtom op + formatPren op + +formatApplication u == + [op,a] := u + MEMQ(a, $fieldNames) => formatSelection u + atom op => + formatHasDotLeadOp a => formatOpPren(op,a) + formatApplication0 u + formatSelection u + +formatHasDotLeadOp u == + u is [op,:.] and (op = "." or not atom op) + +formatApplication0 u == +--format as f(x) as f x if possible + $pilesAreOkHere: local + formatSpill("formatApplication1",u) + +formatApplication1 u == + [op,x] := u + formatHasDollarOp x or $formatForcePren or + pspadBindingPowerOf("left",x) < 1000 => formatOpPren(op,x) + try (formatOp op and format " ") and + (try formatApplication2 x or + format "(" and formatApplication2 x and format ")") + +formatHasDollarOp x == + x is ["elt",a,b] and isTypeProbably? a + +isTypeProbably? x == + IDENTP x and UPPER_-CASE_-P (PNAME x).0 + +formatOpPren(op,x) == formatOp op and formatPren x + +formatApplication2 x == + leadOp := + x is [['elt,.,y],:.] => y + opOf x + MEMQ(leadOp,'(COLLECT LIST construct)) or + pspadBindingPowerOf("left",x)<1000 => formatPren x + format x + +formatDot ["dot",a,x] == + try (formatOp a and format ".") and + ATOM x => format x + formatPren x + +formatSelection u == + $pilesAreOkHere: local + formatSpill("formatSelection1",u) + +formatSelection1 [f,x] == formatSelectionOp f and format "." and + ATOM x => format x + formatPren x + +formatSelectionOp op == + op is [f,.] and not GET(f,'Nud) or + 1000 < pspadBindingPowerOf("right",op) => formatSelectionOp1 op + formatPren1("formatSelectionOp1",op) + +formatSelectionOp1 f == + f is [op,:argl] => + argl is [a] => + not ATOM op and ATOM a => formatSelection1 [op,a] + formatPren f + format f + formatOp f + +formatPren a == + $pilesAreOkHere: local + formatSpill("formatPrenAux",a) + +formatPrenAux a == format "_(" and format a and format "_)" + +formatPren1(f,a) == + $pilesAreOkHere: local + formatSpill2("formatPren1Aux",f,a) + +formatPren1Aux(f,a) == format "_(" and FUNCALL(f,a) and format "_)" + +formatLeft(fn,x,op,key) == + lbp:= formatOpBindingPower(op,key,"left") + formatOpBindingPower(opOf x,key,"right") formatPren1(fn,x) + FUNCALL(fn,x) + +formatRight(fn,x,op,key) == + --are there exceptional cases where piles are ok? + x is ['LET,:.] => FUNCALL(fn,x) + --decide on basis of binding power whether prens are needed + rbp := formatOpBindingPower(op,key,"right") + lbp := formatOpBindingPower(opOf x,key,"left") + lbp < rbp => formatPren1(fn,x) + FUNCALL(fn,x) + +formatCut a == formatSpill("format",a) + +--====================================================================== +-- Prefix/Infix Operators +--====================================================================== +formatPrefix(op,arg,lbp,rbp,:options) == + qualification := IFCAR options + $pilesAreOkHere: local + formatPrefixOp(op,qualification) and + (rbp>formatGetBindingPowerOf("left",arg) => formatPren arg; format arg) + +formatPrefixOp(op,:options) == + qualification := IFCAR options + op=char '" " => format " =" + qualification or GET(op,"Nud") and ^MEMQ(op,$spadTightList) => + formatQual(op,qualification) and format " " + format op + +formatQual(op,D) == + null D => format op + format op and format "$$" and format D + +formatInfix(op,[a,b],lbp,rbp,:options) == + qualification := IFCAR options + $pilesAreOkHere: local + (if formatGetBindingPowerOf("right",a)formatGetBindingPowerOf("left",b) + then formatPren b else format b) + +formatGetBindingPowerOf(leftOrRight,x) == +-- this function is nearly identical with getBindingPowerOf +-- leftOrRight = "left" => 0 +-- 1 + pspadBindingPowerOf(leftOrRight,x) + +pspadBindingPowerOf(key,x) == + --binding powers can be found in file NEWAUX LISP + x is ['REDUCE,:.] => (key='left => 130; key='right => 0) + x is ["REPEAT",:.] => (key="left" => 130; key="right" => 0) + x is ["COND",:.] => (key="left" => 130; key="right" => 0) + x is [op,:argl] => + if op is [a,:.] then op:= a + op = 'SLASH => pspadBindingPowerOf(key,["/",:argl]) - 1 + op = 'OVER => pspadBindingPowerOf(key,["/",:argl]) + (n:= #argl)=1 => + key="left" and (m:= pspadOpBindingPower(op,"Nud","left")) => m + key="right" and (m:= pspadOpBindingPower(op,"Nud","right")) => m + 1000 + n>1 => + key="left" and (m:= pspadOpBindingPower(op,"Led","left")) => m + key="right" and (m:= pspadOpBindingPower(op,"Led","right")) => m + op="ELT" => 1002 + 1000 + 1000 + 1002 + +pspadOpBindingPower(op,LedOrNud,leftOrRight) == + if op in '(SLASH OVER) then op := "/" + MEMQ(op,'(_:)) and LedOrNud = 'Led => + leftOrRight = 'left => 195 + 196 + exception:= + leftOrRight="left" => 0 + 105 + bp:= + leftOrRight="left" => leftBindingPowerOf(op,LedOrNud) + rightBindingPowerOf(op,LedOrNud) + bp^=exception => bp + 1000 + +formatOpBindingPower(op,key,leftOrRight) == + if op in '(SLASH OVER) then op := "/" + op = '_$ => 1002 + MEMQ(op,'(_:)) and key = 'Led => + leftOrRight = 'left => 195 + 196 + MEMQ(op,'(_^_= _>_=)) => 400 + op = "not" and key = "Nud" => + leftOrRight = 'left => 1000 + 1001 + GETL(op,key) is [.,.,:r] => + leftOrRight = 'left => KAR r or 0 + KAR KDR r or 1 + 1000 + +formatInfixOp(op,:options) == + qualification := IFCAR options + qualification or + (op ^= '_$) and ^MEMQ(op,$spadTightList) => format " " and formatQual(op,qualification) and format " " + format op + +--====================================================================== +-- Special Handlers: DEF forms +--====================================================================== + +formatDEF def == formatDEF0(def,$DEFdepth + 1) + +formatDEF0(["DEF",form,tlist,sclist,body],$DEFdepth) == + if not MEMQ(KAR form,'(Exports Implementation)) then + $form := + form is [":",a,:.] => a + form + con := opOf $form + $comments: local := SUBST('_$,'_%,GETDATABASE(con,'DOCUMENTATION)) + $abb :local := constructor? opOf $form + if $DEFdepth < 2 then + condoc := (u := LASSOC('constructor,$comments)) and KDR KAR u or ['""] + $numberOfSpills := -1 + consComments(condoc,'"+++ ") + form := formatDeftranForm(form,tlist) + u := ["DEF",form,tlist,sclist,body] + v := formatDEF1 u => v + $insideDEF: local := $DEFdepth > 1 + $DEFdepth = 1 => + exname := 'Exports + impname := 'Implementation + form is [":",.,=exname] or body = impname => nil + exports := + form is [":",a,b] => + form := a + [["MDEF",exname,'(NIL),'(NIL),b]] + nil + [op,:argl] := form +-- decls := [x for x in argl | x is [":",:.]] +-- form := [op,:[(a is [":",b,t] => b; a) for a in argl]] +-- $DEFdepth := $DEFdepth - 1 + formatWHERE(["where", + ["DEF",[":",form,exname],[nil for x in form],sclist,impname], + ['PROGN,:exports,["MDEF",impname,'(NIL),'(NIL),body]]]) + $insideTypeExpression: local := true + body := formatDeftran(body,false) + body is ["add",a,:b] => formatAddDef(form,a,b) +--body is ["with",a,:b] => formatWithDef(form,a,b) + tryBreakNB(format form and format " == ",body,"==","Led") + +formatDEF1 ["DEF",form,tlist,b,body] == + $insideDEF: local := $DEFdepth > 1 + $insideEXPORTS: local := form = 'Exports + $insideTypeExpression: local := true + form := formatDeftran(form,false) + body := formatDeftran(body,false) + ---------> terrible, hideous, but temporary, hack + if not $insideDEF and body is ['SEQ,:.] then body := ["add", body] + prefix := (opOf tlist = 'Category => "define "; nil) + body is ["add",a,b] => formatAddDef(form,a,b) + body is ["with",a,:b] => formatWithDef(form,a,b,"==",prefix) + prefix => + tryBreak(format prefix and format form and format " == ",body,"==","Led") + tryBreak(format form and format " == ",body,"==","Led") + +formatDefForm(form,:options) == + prefix := IFCAR options + $insideTypeExpression : local := true + form is [":",form1,["with",a,:b]] => formatWithDef(form1,a,b,":",prefix) + prefix => format prefix and format form + format form + +formatAddDef(form,a,b) == + $insideCAPSULE : local := true + $insideDEF : local := false + formatDefForm form or return nil + $marginStack := [0] + $m := $c := 0 + $insideTypeExpression : local := false + cap := (b => b; "") + tryBreakNB(newLine() and format "== " and formatLeft("format",a,"add","Led") + and format " add ", cap,"add","Led") + +formatWithDef(form,a,b,separator,:options) == + prefix := IFCAR options + $insideEXPORTS : local := true + $insideCAPSULE : local := true + $insideDEF : local := false + $insideTypeExpression : local := false + a1 := formatWithKillSEQ a + b => tryBreakNB(formatDefForm(form,prefix) and format separator and format " with " and formatLeft("format",a,"with","Led") + and format " with ",first b,"with","Led") + tryBreak(formatDefForm(form,prefix) and format separator and format " with ",a1,"with","Nud") + +formatWithKillSEQ x == + x is ['SEQ,['exit,.,y]] => ['BRACE, y] + x + +formatBrace ['BRACE, x] == format "{" and format x and format "}" + +formatWith ["with",a,:b] == + $pilesAreOkHere: local := true + b => + tryBreakNB(formatLeft("format",a,"with","Led") and format " with ",first b,"with","Led") + tryBreak(format "with ",a,"with","Nud") + +formatWithDefault ["withDefault",a,b] == + if a is ['with,:init,["SEQ",:items,["exit",.,x]]] then + part2 := ["SEQ",:items,x,["exit", nil,["defaultDefs", b]]] + if IFCAR init then + a:= IFCAR init + b:= [part2] + else + a := part2 + b := nil + $pilesAreOkHere: local := true + b => + tryBreakNB(formatLeft("format",a,"with","Led") and format " with ",first b,"with","Led") + tryBreak(format "with ",a,"with","Nud") + +formatDefaultDefs ["default",a, :b] == + $insideCAPSULE : local := true + $insideDEF : local := false + $insideTypeExpression : local := false + b => + tryBreak(formatLeft("format",a,"default","Led") and + format " default ", first b,"default","Led") + tryBreak(format "default ",a,"default","Nud") +--format "add " and formatRight("formatPreferPile",a,"add","Nud") --==> brace + +formatAdd ["add",a,:b] == + $insideCAPSULE : local := true + $insideDEF : local := false + $insideTypeExpression : local := false + b => + tryBreakNB(formatLeft("format",a,"and","Led") and + format " and ", first b,"and","Led") + tryBreakNB(format "add ",a,"and","Nud") +--format "add " and formatRight("formatPreferPile",a,"add","Nud") --==> brace + +formatMDEF ["MDEF",form,.,.,body] == + form is '(Rep) => formatDEF ["DEF",form,.,.,body] + $insideEXPORTS: local := form = 'Exports + $insideTypeExpression: local := true + body := formatDeftran(body,false) + name := opOf form + tryBreakNB(format name and format " ==> ",body,"==","Led") + and ($insideCAPSULE and $c or format(";")) + +insideCat() == $insideCategoryIfTrue and not $insideFunctorIfTrue + or $noColonDeclaration + +formatImport ["import",a] == + addFieldNames a + addFieldNames macroExpand(a,$e) + format "import from " and formatLocal1 a + +addFieldNames a == + a is [op,:r] and MEMQ(op,'(Record Union)) => + $fieldNames := union(getFieldNames r,$fieldNames) + a is ['List,:b] => addFieldNames b + nil + +getFieldNames r == + r is [[":",a,b],:r] => [a,:getFieldNames r] + nil + +formatLocal ["local",a] == format "local " and formatLocal1 a + +formatLocal1 a == + $insideTypeExpression: local := true + format a + diff --git a/src/interp/pspad1.boot.pamphlet b/src/interp/pspad1.boot.pamphlet deleted file mode 100644 index 408ff6f5..00000000 --- a/src/interp/pspad1.boot.pamphlet +++ /dev/null @@ -1,767 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/pspad1.boot} Pamphlet} -\author{The Axiom Team} - -\begin{document} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\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" - -$escapeWords := ["always", "assert", "but", "define", - "delay", "do", "except", "export", "extend", "fix", "fluid", - "from", "generate", "goto", "import", "inline", "never", "select", - "try", "yield"] -$pileStyle := false -$commentIndentation := 8 -$braceIndentation := 8 -$doNotResetMarginIfTrue := true -$marginStack := nil -$numberOfSpills := 0 -$lineFragmentBuffer:= nil -$pspadRelationAlist := '((_= . _~_=) (_< . _>_=) (_<_= . _>)(_~_= . _=)(_>_= . _<) (_> . _<_=)) -$lineBuffer := nil -$formatForcePren := nil -$underScore := char ('__) -$rightBraceFlag := nil -$semicolonFlag := nil -$newLineWritten := nil -$comments := nil -$noColonDeclaration := false -$renameAlist := '( - (SmallInteger . SingleInteger) - (SmallFloat . DoubleFloat) - (Void . _(_)) - (xquo . exquo) - (setelt . set_!) - (_$ . _%) - (_$_$ . _$) - (_*_* . _^) - (_^_= . _~_=) - (_^ . _~)) - ---$opRenameAlist := '( --- (and . AND) --- (or . OR) --- (not . NOT)) - - ---====================================================================== --- Main Translator Function ---====================================================================== ---% lisp-fragment to boot-fragment functions -lisp2Boot x == - --entry function - $fieldNames := nil - $pilesAreOkHere: local:= true - $commentsToPrint: local:= nil - $lineBuffer: local - $braceStack: local := nil - $marginStack: local:= [0] - --$autoLine is true except when inside a try---if true, lines are allowed to break - $autoLine:= true - $lineFragmentBuffer:= nil - $bc:=0 --brace count - $m:= 0 - $c:= $m - $numberOfSpills:= 0 - $lineLength:= 80 - format x - formatOutput REVERSE $lineFragmentBuffer - [fragmentsToLine y for y in REVERSE $lineBuffer] - -fragmentsToLine fragments == - string:= lispStringList2String fragments - line:= GETSTR 240 - for i in 0..MAXINDEX string repeat line:= SUFFIX(string.i,line) - line - -lispStringList2String x == - null x => '"" - atom x => STRINGIMAGE x - CDR x => APPLY(function STRCONC,MAPCAR(function lispStringList2String,x)) - lispStringList2String CAR x - ---% routines for buffer and margin adjustment - -formatOutput x == - for [currentColumn,start,end,stack] in REVERSE $commentsToPrint repeat - startY:= rest start - for [loc,comment] in stack repeat - commentY:= rest loc - gap:= startY-commentY - gap>0 => before:= [[commentY,first loc,gap,comment],:before] - gap=0 => same:= [[startY,1,gap,comment],:same] - true => after:= [[startY,first loc,-gap,comment],:after] - if before then putOut before - if same then - [y,:extraLines]:= "append"/[mkCommentLines u for u in orderList same] - line:= fragmentsToLine x - x:= - #line+#y>$lineLength => - (y:= STRCONC(nBlanks $m,y); extraLines:= [y,:extraLines]; x) - [line,y] - consLineBuffer x - for y in extraLines repeat consLineBuffer LIST y - if after then putOut after - $commentsToPrint:= nil - -consLineBuffer x == $lineBuffer := [x,:$lineBuffer] - -putOut x == - eject ("min"/[gap for [.,.,gap,:.] in x]) - for u in orderList x repeat addComment u - -eject n == for i in 2..n repeat consLineBuffer nil - -addComment u == - for x in mkCommentLines u repeat consLineBuffer LIST x - -mkCommentLines [.,n,.,s] == - lines:= breakComments s - lines1:= [fragmentsToLine [nBlanks n,"_{",first lines],:rest lines] - [:l,last]:= lines1 - [:l,fragmentsToLine [last,"_}"]] - -breakComments s == - n:= containsString(s,PNAME "ENDOFLINECHR") => - #s>n+12 => [SUBSTRING(s,0,n),:breakComments SUBSTRING(s,n+12,NIL)] - LIST SUBSTRING(s,0,n) - LIST s - -containsString(x,y) == - --if string x contains string y, return start index - for i in 0..MAXINDEX x-MAXINDEX y repeat - and/[x.(i+j)=y.j for j in 0..MAXINDEX y] => return i - ---====================================================================== --- Character/String Buffer Functions ---====================================================================== -consBuffer item == - if item = '"failed" then item := 'failed - n:= - STRINGP item => 2+#item - IDENTP item => #PNAME item - #STRINGIMAGE item - columnsLeft:= $lineLength-$c - if columnsLeft <= 0 and isCloseDelimiter item then $lineLength := $lineLength + 2 - columnsLeft:= $lineLength-$c - --cheat for semicolons, strings, and delimiters: they are NEVER too long - not isSpecialBufferItem item and (n>columnsLeft or columnsLeft < 0) => - $autoLine => - --is true except within try - formatOutput REVERSE $lineFragmentBuffer - $c:= REMAINDER($m+2*($numberOfSpills:= $numberOfSpills+1), $lineLength) - $lineFragmentBuffer:= LIST nBlanks $c - consBuffer item - nil - $lineFragmentBuffer:= - ^item or IDENTP item => [PNAME item,:$lineFragmentBuffer] - NUMBERP item or CHARP item => [STRINGIMAGE item,:$lineFragmentBuffer] - STRINGP item => ["_"",string2PrintImage item,"_"",:$lineFragmentBuffer] - sayBrightly ['"Unexpected line buffer item: ", STRINGIMAGE item] - $lineFragmentBuffer - $rightBraceFlag := item = "}" - $semicolonFlag := item = "; " --prevents consecutive semicolons - $c:= $c+n - -isSpecialBufferItem item == - item = "; " or STRINGP item => true - false - -isCloseDelimiter item == EQ(item,")") or EQ(item,"]") or EQ(item,"}") - ---====================================================================== --- Formatting/Line Control Functions ---====================================================================== -newLine() == - null $autoLine => nil - $newLineWritten := true - formatOutput REVERSE $lineFragmentBuffer - $lineFragmentBuffer:= LIST nBlanks $m - $c:= $m - -optNewLine() == - $newLineWritten => newLine() - $c - -spillLine() == - null $autoLine => nil - formatOutput REVERSE $lineFragmentBuffer - $c:= $m+2*($numberOfSpills:= $numberOfSpills+1) - $lineFragmentBuffer:= LIST nBlanks $c - $c - -indent() == - $m:= $m+2*($numberOfSpills+1) - $marginStack:= [$m,:$marginStack] - $numberOfSpills:= 0 - $m - -undent() == --- $doNotResetMarginIfTrue=true => --- pp '"hoho" --- $c - $marginStack is [m,:r] => - $marginStack := r - $m := m - 0 - -spill(fn,a) == - u := try FUNCALL(fn,a) => u - (nearMargin() or spillLine()) and FUNCALL(fn,a) - -formatSpill(fn,a) == - u := try FUNCALL(fn,a) => u - v := (stay:= nearMargin() or indent() and newLine()) and FUNCALL(fn,a) - w := stay or undent() - v and w - -formatSpill2(fn,f,a) == - u := try FUNCALL(fn,f,a) => u - v := (stay:= nearMargin() or indent() and newLine()) and FUNCALL(fn,f,a) - w := stay or undent() - v and w - -nearMargin() == - $c=$m or $c=$m+1 => $c - ---====================================================================== --- Main Formatting Functions ---====================================================================== -format(x,:options) == - oldC:= $c - qualification := IFCAR options - newCOrNil:= - x is [op,:argl] => - if op = 'return then argl := rest argl - n := #argl - op is ['elt,y,"construct"] => formatDollar(y,'construct,argl) - op is ['elt,name,p] and UPPER_-CASE_-P (STRINGIMAGE opOf name).0 => - formatDollar(name,p,argl) - op = 'elt and UPPER_-CASE_-P (STRINGIMAGE opOf CAR argl).0 => - formatDollar1(CAR argl,CADR argl) - fn:= GETL(op,"PSPAD") => formatFn(fn,x,$m,$c) - if MEMQ(op,'(AND OR NOT)) then op:= DOWNCASE op - n=1 and GETL(op,'Nud) and (lbp:= formatOpBindingPower(op,"Nud","left")) => - formatPrefix(op,first argl,lbp,formatOpBindingPower(op,"Nud","right"),qualification) - n=2 and (op = '_$ or getOp(op,'Led)) and (lbp:= formatOpBindingPower(op,"Led","left")) => - formatInfix(op,argl,lbp,formatOpBindingPower(op,"Led","right"),qualification) - formatForm x - formatAtom x - null newCOrNil => ($c:= oldC; nil) - null FIXP newCOrNil => error() - $c:= newCOrNil - - -getOp(op,kind) == - kind = 'Led => - MEMQ(op,'(_div _exquo)) => nil - GET(op,'Led) - GET(op,'Nud) - -formatDollar(name,p,argl) == - name := markMacroTran name - n := #argl - kind := (n=1 => "Nud"; "Led") - IDENTP name and GETL(p,kind) => format([p,:argl],name) - formatForcePren [p,:argl] and - (try (format "$$" and formatForcePren name) - or (indent() and format "$__" and formatForcePren name and undent())) - -formatMacroCheck name == - ATOM name => name - u := or/[x for [x,:y] in $globalMacroStack | y = name] => u - u := or/[x for [x,:y] in $localMacroStack | y = name] => u - [op,:argl] := name - MEMQ(op,'(Record Union)) => - pp ['"Cannot find: ",name] - name - [op,:[formatMacroCheck x for x in argl]] - -formatDOLLAR ['DOLLAR,x,y] == formatDollar1(y, x) - -formatDollar1(name,arg) == - id := - IDENTP name => name - name is [p] and GETL(p,'NILADIC) => p - name - format arg and format "$$" and formatForcePren id - - -formatForcePren x == - $formatForcePren: local := true - format x - -formatAtom(x,:options) == - if u := LASSOC(x,$renameAlist) then x := u - null x or isIdentifier x => - if MEMQ(x,$escapeWords) then - consBuffer $underScore - consBuffer ident2PrintImage PNAME x - consBuffer x - -formatFn(fn,x,$m,$c) == FUNCALL(fn,x) - -formatFree(['free,:u]) == - format 'free and format " " and formatComma u - -formatUnion(['Union,:r]) == - $count : local := 0 - formatFormNoColonDecl formatTestForPartial ['Union,:[fn x for x in r]] where fn x == - x is [":",y,'Branch] => fn STRINGIMAGE y - STRINGP x => [":", INTERN x, ['Enumeration,x]] - x is [":",:.] => x - tag := INTERN STRCONC("value",STRINGIMAGE ($count := $count + 1)) - [":", tag, x] - -formatTestForPartial u == - u is ['Union,a,b] and b is [":","failed",:.] and a is [":",.,S] => - ['Partial, S] - u - -formatEnumeration(y is ['Enumeration,:r]) == - r is [x] => format "'" and format INTERN STRINGIMAGE x and format "'" - formatForm y - -formatRecord(u) == formatFormNoColonDecl u - -formatFormNoColonDecl u == - $noColonDeclaration: local := true - formatForm u - -formatElt(u) == - u is ["elt",a,b] => formatApplication rest u - formatForm u - -formatForm (u) == - [op,:argl] := u - if MEMQ(op, '(Record Union)) then - $fieldNames := union(getFieldNames argl,$fieldNames) - MEMQ(op,'((QUOTE T) true)) => format "true" - MEMQ(op,'(false nil)) => format op - u='(Zero) => format 0 - u='(One) => format 1 - 1=#argl => formatApplication u - formatFunctionCall u - -formatFunctionCall u == - $pilesAreOkHere: local - spill("formatFunctionCall1",u) - -formatFunctionCall1 [op,:argl] == ---null argl and getConstructorProperty(op,'niladic) => formatOp op - null argl => - GETL(op,'NILADIC) => formatOp op - formatOp op and format "()" - formatOp op and formatFunctionCallTail argl - -formatFunctionCallTail argl == format "_(" and formatComma argl and format "_)" - -formatComma argl == - format first argl and (and/[format "," and formatCut x for x in rest argl]) and $c - -formatOp op == - atom op => formatAtom op - formatPren op - -formatApplication u == - [op,a] := u - MEMQ(a, $fieldNames) => formatSelection u - atom op => - formatHasDotLeadOp a => formatOpPren(op,a) - formatApplication0 u - formatSelection u - -formatHasDotLeadOp u == - u is [op,:.] and (op = "." or not atom op) - -formatApplication0 u == ---format as f(x) as f x if possible - $pilesAreOkHere: local - formatSpill("formatApplication1",u) - -formatApplication1 u == - [op,x] := u - formatHasDollarOp x or $formatForcePren or - pspadBindingPowerOf("left",x) < 1000 => formatOpPren(op,x) - try (formatOp op and format " ") and - (try formatApplication2 x or - format "(" and formatApplication2 x and format ")") - -formatHasDollarOp x == - x is ["elt",a,b] and isTypeProbably? a - -isTypeProbably? x == - IDENTP x and UPPER_-CASE_-P (PNAME x).0 - -formatOpPren(op,x) == formatOp op and formatPren x - -formatApplication2 x == - leadOp := - x is [['elt,.,y],:.] => y - opOf x - MEMQ(leadOp,'(COLLECT LIST construct)) or - pspadBindingPowerOf("left",x)<1000 => formatPren x - format x - -formatDot ["dot",a,x] == - try (formatOp a and format ".") and - ATOM x => format x - formatPren x - -formatSelection u == - $pilesAreOkHere: local - formatSpill("formatSelection1",u) - -formatSelection1 [f,x] == formatSelectionOp f and format "." and - ATOM x => format x - formatPren x - -formatSelectionOp op == - op is [f,.] and not GET(f,'Nud) or - 1000 < pspadBindingPowerOf("right",op) => formatSelectionOp1 op - formatPren1("formatSelectionOp1",op) - -formatSelectionOp1 f == - f is [op,:argl] => - argl is [a] => - not ATOM op and ATOM a => formatSelection1 [op,a] - formatPren f - format f - formatOp f - -formatPren a == - $pilesAreOkHere: local - formatSpill("formatPrenAux",a) - -formatPrenAux a == format "_(" and format a and format "_)" - -formatPren1(f,a) == - $pilesAreOkHere: local - formatSpill2("formatPren1Aux",f,a) - -formatPren1Aux(f,a) == format "_(" and FUNCALL(f,a) and format "_)" - -formatLeft(fn,x,op,key) == - lbp:= formatOpBindingPower(op,key,"left") - formatOpBindingPower(opOf x,key,"right") formatPren1(fn,x) - FUNCALL(fn,x) - -formatRight(fn,x,op,key) == - --are there exceptional cases where piles are ok? - x is ['LET,:.] => FUNCALL(fn,x) - --decide on basis of binding power whether prens are needed - rbp := formatOpBindingPower(op,key,"right") - lbp := formatOpBindingPower(opOf x,key,"left") - lbp < rbp => formatPren1(fn,x) - FUNCALL(fn,x) - -formatCut a == formatSpill("format",a) - ---====================================================================== --- Prefix/Infix Operators ---====================================================================== -formatPrefix(op,arg,lbp,rbp,:options) == - qualification := IFCAR options - $pilesAreOkHere: local - formatPrefixOp(op,qualification) and - (rbp>formatGetBindingPowerOf("left",arg) => formatPren arg; format arg) - -formatPrefixOp(op,:options) == - qualification := IFCAR options - op=char '" " => format " =" - qualification or GET(op,"Nud") and ^MEMQ(op,$spadTightList) => - formatQual(op,qualification) and format " " - format op - -formatQual(op,D) == - null D => format op - format op and format "$$" and format D - -formatInfix(op,[a,b],lbp,rbp,:options) == - qualification := IFCAR options - $pilesAreOkHere: local - (if formatGetBindingPowerOf("right",a)formatGetBindingPowerOf("left",b) - then formatPren b else format b) - -formatGetBindingPowerOf(leftOrRight,x) == --- this function is nearly identical with getBindingPowerOf --- leftOrRight = "left" => 0 --- 1 - pspadBindingPowerOf(leftOrRight,x) - -pspadBindingPowerOf(key,x) == - --binding powers can be found in file NEWAUX LISP - x is ['REDUCE,:.] => (key='left => 130; key='right => 0) - x is ["REPEAT",:.] => (key="left" => 130; key="right" => 0) - x is ["COND",:.] => (key="left" => 130; key="right" => 0) - x is [op,:argl] => - if op is [a,:.] then op:= a - op = 'SLASH => pspadBindingPowerOf(key,["/",:argl]) - 1 - op = 'OVER => pspadBindingPowerOf(key,["/",:argl]) - (n:= #argl)=1 => - key="left" and (m:= pspadOpBindingPower(op,"Nud","left")) => m - key="right" and (m:= pspadOpBindingPower(op,"Nud","right")) => m - 1000 - n>1 => - key="left" and (m:= pspadOpBindingPower(op,"Led","left")) => m - key="right" and (m:= pspadOpBindingPower(op,"Led","right")) => m - op="ELT" => 1002 - 1000 - 1000 - 1002 - -pspadOpBindingPower(op,LedOrNud,leftOrRight) == - if op in '(SLASH OVER) then op := "/" - MEMQ(op,'(_:)) and LedOrNud = 'Led => - leftOrRight = 'left => 195 - 196 - exception:= - leftOrRight="left" => 0 - 105 - bp:= - leftOrRight="left" => leftBindingPowerOf(op,LedOrNud) - rightBindingPowerOf(op,LedOrNud) - bp^=exception => bp - 1000 - -formatOpBindingPower(op,key,leftOrRight) == - if op in '(SLASH OVER) then op := "/" - op = '_$ => 1002 - MEMQ(op,'(_:)) and key = 'Led => - leftOrRight = 'left => 195 - 196 - MEMQ(op,'(_^_= _>_=)) => 400 - op = "not" and key = "Nud" => - leftOrRight = 'left => 1000 - 1001 - GETL(op,key) is [.,.,:r] => - leftOrRight = 'left => KAR r or 0 - KAR KDR r or 1 - 1000 - -formatInfixOp(op,:options) == - qualification := IFCAR options - qualification or - (op ^= '_$) and ^MEMQ(op,$spadTightList) => format " " and formatQual(op,qualification) and format " " - format op - ---====================================================================== --- Special Handlers: DEF forms ---====================================================================== - -formatDEF def == formatDEF0(def,$DEFdepth + 1) - -formatDEF0(["DEF",form,tlist,sclist,body],$DEFdepth) == - if not MEMQ(KAR form,'(Exports Implementation)) then - $form := - form is [":",a,:.] => a - form - con := opOf $form - $comments: local := SUBST('_$,'_%,GETDATABASE(con,'DOCUMENTATION)) - $abb :local := constructor? opOf $form - if $DEFdepth < 2 then - condoc := (u := LASSOC('constructor,$comments)) and KDR KAR u or ['""] - $numberOfSpills := -1 - consComments(condoc,'"+++ ") - form := formatDeftranForm(form,tlist) - u := ["DEF",form,tlist,sclist,body] - v := formatDEF1 u => v - $insideDEF: local := $DEFdepth > 1 - $DEFdepth = 1 => - exname := 'Exports - impname := 'Implementation - form is [":",.,=exname] or body = impname => nil - exports := - form is [":",a,b] => - form := a - [["MDEF",exname,'(NIL),'(NIL),b]] - nil - [op,:argl] := form --- decls := [x for x in argl | x is [":",:.]] --- form := [op,:[(a is [":",b,t] => b; a) for a in argl]] --- $DEFdepth := $DEFdepth - 1 - formatWHERE(["where", - ["DEF",[":",form,exname],[nil for x in form],sclist,impname], - ['PROGN,:exports,["MDEF",impname,'(NIL),'(NIL),body]]]) - $insideTypeExpression: local := true - body := formatDeftran(body,false) - body is ["add",a,:b] => formatAddDef(form,a,b) ---body is ["with",a,:b] => formatWithDef(form,a,b) - tryBreakNB(format form and format " == ",body,"==","Led") - -formatDEF1 ["DEF",form,tlist,b,body] == - $insideDEF: local := $DEFdepth > 1 - $insideEXPORTS: local := form = 'Exports - $insideTypeExpression: local := true - form := formatDeftran(form,false) - body := formatDeftran(body,false) - ---------> terrible, hideous, but temporary, hack - if not $insideDEF and body is ['SEQ,:.] then body := ["add", body] - prefix := (opOf tlist = 'Category => "define "; nil) - body is ["add",a,b] => formatAddDef(form,a,b) - body is ["with",a,:b] => formatWithDef(form,a,b,"==",prefix) - prefix => - tryBreak(format prefix and format form and format " == ",body,"==","Led") - tryBreak(format form and format " == ",body,"==","Led") - -formatDefForm(form,:options) == - prefix := IFCAR options - $insideTypeExpression : local := true - form is [":",form1,["with",a,:b]] => formatWithDef(form1,a,b,":",prefix) - prefix => format prefix and format form - format form - -formatAddDef(form,a,b) == - $insideCAPSULE : local := true - $insideDEF : local := false - formatDefForm form or return nil - $marginStack := [0] - $m := $c := 0 - $insideTypeExpression : local := false - cap := (b => b; "") - tryBreakNB(newLine() and format "== " and formatLeft("format",a,"add","Led") - and format " add ", cap,"add","Led") - -formatWithDef(form,a,b,separator,:options) == - prefix := IFCAR options - $insideEXPORTS : local := true - $insideCAPSULE : local := true - $insideDEF : local := false - $insideTypeExpression : local := false - a1 := formatWithKillSEQ a - b => tryBreakNB(formatDefForm(form,prefix) and format separator and format " with " and formatLeft("format",a,"with","Led") - and format " with ",first b,"with","Led") - tryBreak(formatDefForm(form,prefix) and format separator and format " with ",a1,"with","Nud") - -formatWithKillSEQ x == - x is ['SEQ,['exit,.,y]] => ['BRACE, y] - x - -formatBrace ['BRACE, x] == format "{" and format x and format "}" - -formatWith ["with",a,:b] == - $pilesAreOkHere: local := true - b => - tryBreakNB(formatLeft("format",a,"with","Led") and format " with ",first b,"with","Led") - tryBreak(format "with ",a,"with","Nud") - -formatWithDefault ["withDefault",a,b] == - if a is ['with,:init,["SEQ",:items,["exit",.,x]]] then - part2 := ["SEQ",:items,x,["exit", nil,["defaultDefs", b]]] - if IFCAR init then - a:= IFCAR init - b:= [part2] - else - a := part2 - b := nil - $pilesAreOkHere: local := true - b => - tryBreakNB(formatLeft("format",a,"with","Led") and format " with ",first b,"with","Led") - tryBreak(format "with ",a,"with","Nud") - -formatDefaultDefs ["default",a, :b] == - $insideCAPSULE : local := true - $insideDEF : local := false - $insideTypeExpression : local := false - b => - tryBreak(formatLeft("format",a,"default","Led") and - format " default ", first b,"default","Led") - tryBreak(format "default ",a,"default","Nud") ---format "add " and formatRight("formatPreferPile",a,"add","Nud") --==> brace - -formatAdd ["add",a,:b] == - $insideCAPSULE : local := true - $insideDEF : local := false - $insideTypeExpression : local := false - b => - tryBreakNB(formatLeft("format",a,"and","Led") and - format " and ", first b,"and","Led") - tryBreakNB(format "add ",a,"and","Nud") ---format "add " and formatRight("formatPreferPile",a,"add","Nud") --==> brace - -formatMDEF ["MDEF",form,.,.,body] == - form is '(Rep) => formatDEF ["DEF",form,.,.,body] - $insideEXPORTS: local := form = 'Exports - $insideTypeExpression: local := true - body := formatDeftran(body,false) - name := opOf form - tryBreakNB(format name and format " ==> ",body,"==","Led") - and ($insideCAPSULE and $c or format(";")) - -insideCat() == $insideCategoryIfTrue and not $insideFunctorIfTrue - or $noColonDeclaration - -formatImport ["import",a] == - addFieldNames a - addFieldNames macroExpand(a,$e) - format "import from " and formatLocal1 a - -addFieldNames a == - a is [op,:r] and MEMQ(op,'(Record Union)) => - $fieldNames := union(getFieldNames r,$fieldNames) - a is ['List,:b] => addFieldNames b - nil - -getFieldNames r == - r is [[":",a,b],:r] => [a,:getFieldNames r] - nil - -formatLocal ["local",a] == format "local " and formatLocal1 a - -formatLocal1 a == - $insideTypeExpression: local := true - format a - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/pspad2.boot b/src/interp/pspad2.boot new file mode 100644 index 00000000..e5af3357 --- /dev/null +++ b/src/interp/pspad2.boot @@ -0,0 +1,663 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- 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" + +--====================================================================== +-- Constructor Transformation Functions +--====================================================================== +formatDeftranForm(form,tlist) == + [ttype,:atypeList] := tlist + if form is [":",f,t] then + form := f + ttype := t + if form is ['elt,a,b] then ----> a.b ====> apply(b,a) + form := + isTypeProbably? a => + atypeList := REVERSE atypeList + ["$$", b, a] + ["apply",a, b] + op := KAR form + argl := KDR form + if or/[t for t in atypeList] then + form := [op,:[(t => [":",a,t]; a) for a in argl for t in atypeList]] + if ttype then form := [":",form,ttype] + form + +formatDeftran(u,SEQflag) == + u is ['Join,:x] => formatDeftranJoin(u,SEQflag) + u is ['CATEGORY,kind,:l,x] => formatDeftran(['with,['SEQ,:l,['exit,n,x]]],SEQflag) + u is ['CAPSULE,:l,x] => formatDeftranCapsule(l,x,SEQflag) + u is [op,:.] and MEMQ(op,'(rep per)) => formatDeftranRepper(u,SEQflag) + u is [op,:.] and MEMQ(op,'(_: _:_: _pretend _@)) => + formatDeftranColon(u,SEQflag) + u is ['PROGN,:l,x] => formatDeftran(['SEQ,:l,['exit,1,x]],SEQflag) + u is ['SEQ,:l,[.,n,x]] => + v := [:l,x] + a := "APPEND"/[formatDeftranSEQ(x,true) for x in l] + b := formatDeftranSEQ(x,false) + if b is [:.,c] and c = '(void) then b := DROP(-1, b) + [:m,y] := [:a,:b] + ['SEQ,:m,['exit,n,y]] +-- u is ['not,arg] and (op := LASSOC(KAR arg,'((_= . _^_=) (_< . _>_=)))) => +-- formatDeftran([op,:CDR arg],nil) + u is ["^",a] => formatDeftran(['not,a],SEQflag) + u is ["exquo",a,b] => formatDeftran(['xquo,a,b],SEQflag) + u is ['IF,a,b,c] => + a := formatDeftran(a,nil) + b := formatDeftran(b,nil) + c := formatDeftran(c,nil) + null SEQflag and $insideDEF => + [:y,last] := formatDeftranIf(a,b,c) + ['SEQ,:y,['exit,1,last]] + ['IF,a,b,c] + u is ['Union,:argl] => + ['Union,:[x for a in argl + | x := (STRINGP a => [":",INTERN a,'Branch]; formatDeftran(a,nil))]] + u is [op,:itl,body] and MEMQ(op,'(REPEAT COLLECT)) and + ([nitl,:nbody] := formatDeftranREPEAT(itl,body)) => + formatDeftran([op,:nitl,nbody],SEQflag) + u is [":",a,b] => [":",formatDeftran(a,nil),formatDeftran(markMacroTran(b),nil)] + u is ["DEF",:.] => formatCapsuleFunction(u) + u is [op,:argl]=>[formatDeftran(op,nil),:[formatDeftran(x,nil) for x in argl]] + u = 'nil => 'empty + u + +formatCapsuleFunction ["DEF",form,tlist,b,body] == + $insideDEF : local := true + ["DEF", formatDeftran(form,nil),tlist,b,formatDeftran(body,nil)] + +formatDeftranCapsule(l,x,SEQflag) == + $insideCAPSULE: local := true + formatDeftran(['SEQ,:l,['exit,1,x]],SEQflag) + +formatDeftranRepper([op,a],SEQflag) == + a is [op1,b] and MEMQ(op1,'(rep per)) => + op = op1 => formatDeftran(a,SEQflag) + formatDeftran(b,SEQflag) + a is ["::",b,t] => + b := formatDeftran(b,SEQflag) + t := formatDeftran(t,SEQflag) + a := ["::",b,t] + op = 'per and t = "$" or op = 'rep and t = 'Rep => a + [op,a] + a is ['SEQ,:r] => ['SEQ,:[formatSeqRepper(op,x) for x in r]] + a is ['IF,p,b,c] => + formatDeftran(['IF,p,[op,b],[op, c]], SEQflag) + a is ['LET,a,b] => formatDeftran(['LET,a,[op,b]],SEQflag) + a is ['not,[op,a,b]] and (op1 := LASSOC(op,$pspadRelationAlist)) => + formatDeftran [op1,a,b] + a is ['return,n,r] => + MEMQ(opOf r,'(true false)) => a + ['return,n,[op,formatDeftran(r,SEQflag)]] + a is ['error,:.] => a + [op,formatDeftran(a,SEQflag)] + +formatDeftranColon([op,a,t],SEQflag) == --op is one of : :: pretend @ + a := formatDeftran(a,SEQflag) + t := formatDeftran(t,SEQflag) + a is ["UNCOERCE",b] => b + a is [op1,b,t1] and t1 = t and MEMQ(op,'(_: _:_: _pretend _@)) => + op1 = "pretend" or op = "pretend" => ["pretend",b,t] + null SEQflag and op1 = ":" or op = ":" => ["pretend",b,t] + a + a is [=op,b,t1] => + t1 = t => a + [op,b,t] + t = "$" => + a is ['rep,b] => b + a is ['per,b] => a + [op,a,t] + t = "Rep" => + a is ['per,b] => b + a is ['rep,b] => a + [op,a,t] + [op,a,t] + +formatSeqRepper(op,x) == + x is ['exit,n,y] => ['exit,n,[op,formatDeftran(y,nil)]] + x is ["=>",a,b] => ["=>",formatDeftran(a,nil),[op,formatDeftran(b,nil)]] + atom x => x + [formatSeqRepper(op,y) for y in x] + +formatDeftranJoin(u,SEQflag) == + ['Join,:cats,lastcat] := u + lastcat is ['CATEGORY,kind,:l,x] => + cat := + CDR cats => ['Join,:cats] + first cats + formatDeftran(['with,cat,['SEQ,:l,['exit,1,x]]],SEQflag) + u + +formatENUM ['MyENUM, x] == format "'" and format x and format "'" + +formatDeftranREPEAT(itl,body) == +--do nothing unless "itl" contains UNTIL statements + u := [x for x in itl | x is ["UNTIL",p]] or return nil + nitl := SETDIFFERENCE(itl,u) + pred := MKPF([p for ['UNTIL,p] in u],'or) + cond := ['IF,pred,['leave,n,nil],'noBranch] + nbody := + body is ['SEQ,:l,[.,n,x]] => ['SEQ,:l,x,['exit,n,cond]] + ['SEQ,body,['exit,n,cond]] + [nitl,:nbody] + +formatDeftranSEQ(x,flag) == + u := formatDeftran(x,flag) + u is ['SEQ,:.] => rest u + [u] + +formatDeftranIf(a,b,c) == + b = 'noBranch => + a is [op,:r] and (al := '((_= . _~_=) (_< . _>_=) (_> . _<_=)); + iop := LASSOC(op, al) or rassoc(op, al)) => + [["=>",[iop, :r],c]] + a is [op,r] and MEMQ(op,'(NOT not NULL null)) => + [["=>", r, c]] + [["=>", ['not, a], c]] + post := + c = 'noBranch => nil + c is ['SEQ,:.] => CDR c + [c] + [["=>",a,b],:post] + +formatWHERE ["where",a,b] == + $insideTypeExpression: local := nil + $insideCAPSULE: local := false + tryBreak(formatLeft("format",a,"where","Led") and format " where ",b,"where","Led") + +--====================================================================== +-- Special Handlers: Categories +--====================================================================== +formatATTRIBUTE ['ATTRIBUTE,att] == format att + +formatDeftranCategory ['CATEGORY,kind,:items,item] == ["SEQ",:items,["exit",1,item]] + +formatCategory ['Category] == format " " and format "Category" + +formatCATEGORY cat == + con := opOf $form + $comments: local := SUBST('_$,'_%,GETDATABASE(con,'DOCUMENTATION)) + $insideEXPORTS : local := true + format ["with",formatDeftranCategory cat] + +formatSIGNATURE ['SIGNATURE,op,types,:r] == + MEMQ('constant,r) => format op and format ": " and (u := format first types) and + formatSC() and formatComments(u,op,types) + format op and format ": " and (u := format ['Mapping,:types]) and formatSC() and + formatComments(u,op,types) + +formatDefault ["default",a] == + $insideCategoryIfTrue : local := false + $insideCAPSULE: local := true + $insideTypeExpression: local := false + tryBreak(format "default ",a,"with","Nud") +--====================================================================== +-- Special Handlers: Control Structures +--====================================================================== +formatUNCOERCE ['UNCOERCE,x] == format x + +formatIF ['IF,a,b,c] == + c = 'noBranch => formatIF2(a,b,"if ") + b = 'noBranch => formatIF ['IF,['not,a],c,'noBranch] + formatIF2(a,b,"if ") and newLine() and formatIF3 c + +formatIF2(a,b,prefix) == + tryBreakNB(format prefix and format a and format " then ",b,"then","Nud") + +formatIF3 x == + x is ['IF,a,b,c] => + c = 'noBranch => tryBreak(format "else if " + and format a and format " then ",b,"then","Nud") + formatIF2(a,b,"else if ") and newLine() and formatIF3 c + tryBreak(format "else ",x,"else","Nud") + +formatBlock(l,x) == + null l => format x + $pilesAreOkHere: local + format "{ " and format first l and + (and/[formatSC() and format y for y in rest l]) + and formatSC() and format x and format " }" + +formatExit ["exit",.,u] == format u + +formatvoid ["void"] == format "()" + +formatLeave ["leave",.,u] == format "break" + +formatCOLLECT u == formatSpill("formatCOLLECT1",u) + +formatCOLLECT1 ["COLLECT",:iteratorList,body] == + $pilesAreOkHere: local + format "[" and format body and format " " and + formatSpill("formatIteratorTail",iteratorList) + +formatIteratorTail iteratorList == + formatIterator first iteratorList and + (and/[format " " and formatIterator x for x in rest iteratorList]) and format "]" + +--====================================================================== +-- Special Handlers: Keywords +--====================================================================== + +formatColon [":",a,b] == + b is ['with,c,:d] => formatColonWith(a,c,d) + if not $insideTypeExpression then + insideCat() => nil + format + $insideDEF => "local " + "default " + op := + $insideCAPSULE and not $insideDEF => ": " + insideCat() => ": " + ":" + b := (atom b => b; markMacroTran b) + a is ['LISTOF,:c] => formatComma c and format ": " and formatLocal1 b + formatInfix(op,[a, b],formatOpBindingPower(":","Led","left"), + formatOpBindingPower(":","Led","right")) + +formatColonWith(form,a,b) == + con := opOf $form + $comments: local := SUBST('_$,'_%,GETDATABASE(con,'DOCUMENTATION)) + $insideEXPORTS : local := true + $pilesAreOkHere: local := true + $insideTypeExpression : local := false + b => tryBreak(formatDefForm form and format ": " + and format a and format " with ",first b,"with","Led") + tryBreak(formatDefForm form and format ": with ",a,"with","Nud") + +formatCOND ["COND",:l] == + originalC:= $c + and/[x is [a,[.,.,b]] for x in l] => + (originalC=$m or indent() and newLine()) and first l is [a,[.,.,b]] and + formatIfExit(a,b) and + (and/[newLine() and formatIfExit(a,b) for [a,[.,.,b]] in rest l]) and (originalC=$m or undent()) and originalC + formatIfThenElse l + +formatPROGN ["PROGN",:l] == + l is [:u,x] => formatPiles(u,x) + error '"formatPROGN" + +formatELT ["ELT",a,b] == formatApplication [a,b] + +formatCONS ["CONS",a,b] == + $pilesAreOkHere: local + format "[" and formatConstructItem a and formatTail b + +formatTail x == + null x => format "]" + format "," and formatTail1 x + +formatTail1 x == + x is ["CONS",a,b] => formatConstructItem a and formatTail b + x is ["APPEND",a,b] => + null b => formatConstructItem a and format "]" + format ":" and formatConstructItem a and formatTail b + format ":" and formatConstructItem x and format "]" + +-- x = "." => format " " +formatConstructItem x == format x + +formatLET ["LET",a,b] == + $insideTypeExpression: local := true + a = "Rep" or atom a and constructor? opOf b => + tryBreakNB(formatAtom a and format " == ",b,":=","Led") + tryBreakNB((IDENTP a => formatAtom a; format a) and format " := ",b,":=","Led") + +formatIfExit(a,b) == + --called from SCOND or COND only + $numberOfSpills: local:= 0 + curMargin:= $m + curMarginStack:= $currentMarginStack + $doNotResetMarginIfTrue:= true + format a and format " => " and formatRight("formatCut",b,"=>","Led") => + ($currentMarginStack:= curMarginStack; $m:= curMargin) + +formatIfThenElse x == formatSpill("formatIf1",x) + +formatIf1 x == + x is [[a,:r],:c] and null c => + b:= + r is [:l,s] and l => ['SEQ,:l,['exit,.,s]] + first r + isTrue a => format b + format "if " and format a and format " then " and format b + format "if " and format a and + (try + (format " then " and format b and format " else " + and formatIfThenElse c) or spillLine() + and format " then " and format b and +-- ($c:= $m:= $m+6) and + ($numberOfSpills:= $numberOfSpills-1) + and spillLine() and format " else " and formatIfThenElse c) + +formatQUOTE ["QUOTE",x] == format "('" and format x and format ")" + +formatMI ["MI",a,b] == format a + +formatMapping ['Mapping,target,:sources] == + $noColonDeclaration: local := true + formatTuple ['Tuple,:sources] and format " -> " and format target + +formatTuple ['Tuple,:types] == + null types => format "()" + null rest types => format first types + formatFunctionCallTail types + +formatConstruct(['construct,:u]) == + format "[" and (null u or format first u and + "and"/[format "," and formatCut x for x in rest u]) and format "]" + +formatNextConstructItem x == + try format x or ($m := $m + 2) and newLine() and format x + +formatREPEAT ["REPEAT",:iteratorList,body] == + tryBreakNB(null iteratorList or (formatIterator first iteratorList and + (and/[format " " and formatIterator x for x in rest iteratorList]) and format " ") + and format "repeat ",body,"repeat","Led") + +formatFATARROW ["=>",a,b] == tryBreak(format a and format " => ",b,"=>","Led") + +formatMap ["+->",a,b] == + $noColonDeclaration: local := true + tryBreak(format a and format " +-> ", b, "+->","Led") + +formatREDUCE ["REDUCE",op,.,u] == formatReduce1(op,u) + +formatreduce ["reduce",op,u] == formatReduce1(op,u) + +formatReduce1(op,u) == + if STRINGP op then op := INTERN op + id := LASSOC(op, + '((_+ Zero)(_* One)(append . NIL)(gcd Zero) (lcm One) (strconc . "")(lcm One))) + formatFunctionCall + id => ['reduce,op,u,id] + ['reduce,op,u] + +formatIterator u == + $noColonDeclaration : local := true + u is ["IN",x,y] => + format "for " and formatLeft("format",x,"in","Led") and format " in " and + formatRight("format",y,"in","Led") + u is ["WHILE",x] => format "while " and formatRight("format",x,"while","Nud") + u is ["UNTIL",x] => format "until " and formatRight("format",x,"until","Nud") + u is ["|",x] => format "| " and formatRight("format",x,"|","Led") + u is ["STEP",i,init,step,:v] => + final := IFCAR v + format "for " and formatLeft("format",i,"in","Led") and format " in " and + (seg := ['SEGMENT,init,final]) and (formatStepOne? step => format seg; formatBy ['by,seg,step]) + error "formatIterator" + +formatStepOne? step == + step = 1 or step = '(One) => true + step is [op,n,.] and MEMQ(op,'(_:_: _@)) => n = 1 or n = '(One) + false + +formatBy ['by,seg,step] == format seg and format " by " and format step + +formatSCOND ["SCOND",:l] == + $pilesAreOkHere => + --called from formatPileLine or formatBlock + --if from formatPileLine + initialC:= $c + and/[x is [a,["exit",.,b]] for x in l] => + first l is [a,["exit",.,b]] and formatIfExit(a,b) and + (and/[newLine() and formatIfExit(a,b) for [a,["exit",.,b]] in rest l]) and initialC + formatIfThenElse l and initialC + and/[x is [a,["exit",.,b]] for x in l] => + first l is [a,["exit",.,b]] and formatIfExit(a,b) and + (and/[format "; " and formatIfExit(a,b) for [a,["exit",.,b]] in rest l]) and $c + --warning: and/(...) returns T if there are no entries + formatIfThenElse l + +formatSEGMENT ["SEGMENT",a,b] == + $pilesAreOkHere: local + (if pspadBindingPowerOf("right",a)<750 then formatPren a else format a) and + formatInfixOp ".." and + (null b and $c or + (if 750>pspadBindingPowerOf("left",b) then formatPren b else format b)) + +formatSexpr x == + atom x => + null x or IDENTP x => consBuffer ident2PrintImage PNAME x + consBuffer x + spill("formatNonAtom",x) + +formatNonAtom x == + format "_(" and formatSexpr first x and + (and/[format " " and formatSexpr y for y in rest x]) + and (y:= LASTATOM x => format " . " + and formatSexpr y; true) and format "_)" + +formatCAPSULE ['CAPSULE,:l,x] == + $insideCAPSULE: local := true + try formatBlock(l,x) or formatPiles(l,x) or spillLine() and formatBlock(l,x) + +formatPAREN [.,:argl] == formatFunctionCallTail argl + +formatSEQ ["SEQ",:l,[.,.,x]] == + try formatBlock(l,x) or formatPiles(l,x) or spillLine() and formatBlock(l,x) + +--====================================================================== +-- Comment Handlers +--====================================================================== +formatCOMMENT ["COMMENT",x,marg,startXY,endXY,commentStack] == + $commentsToPrint:= [[marg,startXY,endXY,commentStack],:$commentsToPrint] + format x + +formatComments(u,op,types) == + $numberOfSpills :local := $commentIndentation/2 - 1 + not $insideEXPORTS => u + alist := LASSOC(op,$comments) or + sayBrightly ['"No documentation for ",op] + return u + ftypes := SUBLISLIS($FormalMapVariableList,rest $form,types) + consComments(LASSOC(ftypes,alist),'"++ ") + u + +consComments(s,plusPlus) == + s is [word,:r] and null atom r => consComments(r, plusPlus) + s := first s + null s => nil + s := consCommentsTran s + indent() and newLine() or return nil + columnsLeft := $lineLength - $m - 2 + while (m := MAXINDEX s) >= columnsLeft repeat + k := or/[i for i in (columnsLeft - 1)..1 by -1 | s.i = $charBlank] + k := (k => k + 1; columnsLeft) + piece := SUBSTRING(s,0,k) + formatDoCommentLine [plusPlus,piece] + s := SUBSTRING(s,k,nil) + formatDoCommentLine [plusPlus,s] + undent() + $m + +consCommentsTran s == + m := MAXINDEX s + k := or/[i for i in 0..(m - 7) | substring?('"\spad{",s,i)] => + r := charPosition(char '_},s,k + 6) + r = m + 1 => s + STRCONC(SUBSTRING(s,0,k),'"`",SUBSTRING(s,k+6,r-k-6),'"'",consCommentsTran SUBSTRING(s,r+1,nil)) + s + +formatDoCommentLine line == + $lineBuffer := consLineBuffer [nBlanks $c,:line] + $c := $m+2*$numberOfSpills + +--====================================================================== +-- Pile Handlers +--====================================================================== +formatPreferPile y == + y is ["SEQ",:l,[.,.,x]] => + (u:= formatPiles(l,x)) => u + formatSpill("format",y) + formatSpill("format",y) + +formatPiles(l,x) == + $insideTypeExpression : local := false + not $pilesAreOkHere => nil + originalC:= $c + lines:= [:l,x] + --piles must begin at margin + originalC=$m or indent() and newLine() or return nil + null (formatPileLine($m,first lines,false)) => nil + not (and/[formatPileLine($m,y,true) for y in rest lines]) => nil + (originalC=$m or undent()) and originalC --==> brace + +formatPileLine($m,x,newLineIfTrue) == + if newLineIfTrue then newLine() or return nil + $numberOfSpills: local:= 0 + $newLineWritten := nil + format x and (x is ['SIGNATURE,:.] or $rightBraceFlag => $c; formatSC()) + and (x is ['DEF,:.] and optNewLine() or $c) + +--====================================================================== +-- Utility Functions +--====================================================================== +nBlanks m == "STRCONC"/[char('_ ) for i in 1..m] + +isNewspadOperator op == GET(op,"Led") or GET(op,"Nud") + +isTrue x == x="true" or x is '(QUOTE T) + +nary2Binary(u,op) == + u is [a,b,:t] => (t => nary2Binary([[op,a,b],:t],op); [op,a,b]) + errhuh() + +string2PrintImage s == + u:= GETSTR (2*SIZE s) + for i in 0..MAXINDEX s repeat + (if MEMQ(s.i,'(_( _{ _) _} _! _")) then + SUFFIX('__,u); u:= SUFFIX(s.i,u)) + u + +ident2PrintImage s == + m := MAXINDEX s + if m > 1 and s.(m - 1) = $underScore then s := STRCONC(SUBSTRING(s,0,m-1),s.m) + u:= GETSTR (2*SIZE s) + if not (ALPHA_-CHAR_-P s.(0) or s.(0)=char '"$") then SUFFIX('__,u) + u:= SUFFIX(s.(0),u) + for i in 1..MAXINDEX s repeat + if not (DIGITP s.i or ALPHA_-CHAR_-P s.i or ((c := s.i) = char '?) + or (c = char '_!)) then SUFFIX('__,u) + u:= SUFFIX(s.i,u) + INTERN u + +isIdentifier x == + IDENTP x => + s:= PNAME x + #s = 0 => nil + ALPHA_-CHAR_-P s.(0) => and/[s.i^=char '" " for i in 1..MAXINDEX s] + #s>1 => + or/[ALPHA_-CHAR_-P s.i for i in 1..(m:= MAXINDEX s)] => + and/[s.i^=char '" " for i in 1..m] => true + +isGensym x == + s := STRINGIMAGE x + n := MAXINDEX s + s.0 = char '_G and and/[DIGITP s.i for i in 1..n] + +--====================================================================== +-- Macro Helpers +--====================================================================== +tryToFit(s,x) == +--% try to format on current line; see macro try in file PSPADAUX LISP + --returns nil if unable to format stuff in x on a single line + x => ($back:= rest $back; $c) + restoreState() + nil + +restoreState(:options) == + back := IFCAR options or $back + [ + [$lineBuffer, $lineFragmentBuffer,$comments,$marginStack,$braceStack,$DEFdepth, + $bc,$c,$m,$commentsToPrint,$numberOfSpills,flags], :back] + := back + if null options then $back := back + [$newLineWritten, $autoLine, $rightBraceFlag, + $semicolonFlag,$insideDEF,$insideTypeExpression,$pilesAreOkHere, + $insideEXPORTS, $insideCAPSULE, $insideCategoryIfTrue, + $doNotResetMarginIfTrue,$noColonDeclaration] + := flags + nil + +saveState(:options) == + flags := + [$newLineWritten, $autoLine, $rightBraceFlag, + $semicolonFlag,$insideDEF,$insideTypeExpression,$pilesAreOkHere, + $insideEXPORTS, $insideCAPSULE, $insideCategoryIfTrue, + $doNotResetMarginIfTrue,$noColonDeclaration] + newState := + [ + [$lineBuffer, $lineFragmentBuffer,$comments,$marginStack,$braceStack,$DEFdepth, + $bc,$c,$m,$commentsToPrint,$numberOfSpills,flags], :$back] + if not KAR options then $back := newState + newState + +formatSC() == + $pileStyle or $semicolonFlag => $c + format "; " + +wrapBraces(x,y,z) == y + +formatLB() == + $pileStyle => $c + $numberOfSpills := + $c > $lineLength / 2 => $braceIndentation/3 - 1 + $braceIndentation/2 - 1 + format "{" + +restoreC() == --used by macro "embrace" + originalC := CAR $braceStack + $braceStack := CDR $braceStack + formatRB originalC + +saveC() == --used by macro "embrace" + $braceStack := [$c,:$braceStack] + +saveD() == --used by macro "embrace" + $braceStack := [$c,:$braceStack] + +restoreD() == --used by macro "indentNB" + originalC := CAR $braceStack + $braceStack := CDR $braceStack + originalC + +formatRB(originalC) == --called only by restoreC + while $marginStack and $m > originalC repeat undent() + if $m < originalC then $marginStack := [originalC,:$marginStack] + $m := originalC + $pileStyle => $m + newLine() and format "}" and $m --==> brace + diff --git a/src/interp/pspad2.boot.pamphlet b/src/interp/pspad2.boot.pamphlet deleted file mode 100644 index 54e9a584..00000000 --- a/src/interp/pspad2.boot.pamphlet +++ /dev/null @@ -1,683 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp pspad2.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\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" - ---====================================================================== --- Constructor Transformation Functions ---====================================================================== -formatDeftranForm(form,tlist) == - [ttype,:atypeList] := tlist - if form is [":",f,t] then - form := f - ttype := t - if form is ['elt,a,b] then ----> a.b ====> apply(b,a) - form := - isTypeProbably? a => - atypeList := REVERSE atypeList - ["$$", b, a] - ["apply",a, b] - op := KAR form - argl := KDR form - if or/[t for t in atypeList] then - form := [op,:[(t => [":",a,t]; a) for a in argl for t in atypeList]] - if ttype then form := [":",form,ttype] - form - -formatDeftran(u,SEQflag) == - u is ['Join,:x] => formatDeftranJoin(u,SEQflag) - u is ['CATEGORY,kind,:l,x] => formatDeftran(['with,['SEQ,:l,['exit,n,x]]],SEQflag) - u is ['CAPSULE,:l,x] => formatDeftranCapsule(l,x,SEQflag) - u is [op,:.] and MEMQ(op,'(rep per)) => formatDeftranRepper(u,SEQflag) - u is [op,:.] and MEMQ(op,'(_: _:_: _pretend _@)) => - formatDeftranColon(u,SEQflag) - u is ['PROGN,:l,x] => formatDeftran(['SEQ,:l,['exit,1,x]],SEQflag) - u is ['SEQ,:l,[.,n,x]] => - v := [:l,x] - a := "APPEND"/[formatDeftranSEQ(x,true) for x in l] - b := formatDeftranSEQ(x,false) - if b is [:.,c] and c = '(void) then b := DROP(-1, b) - [:m,y] := [:a,:b] - ['SEQ,:m,['exit,n,y]] --- u is ['not,arg] and (op := LASSOC(KAR arg,'((_= . _^_=) (_< . _>_=)))) => --- formatDeftran([op,:CDR arg],nil) - u is ["^",a] => formatDeftran(['not,a],SEQflag) - u is ["exquo",a,b] => formatDeftran(['xquo,a,b],SEQflag) - u is ['IF,a,b,c] => - a := formatDeftran(a,nil) - b := formatDeftran(b,nil) - c := formatDeftran(c,nil) - null SEQflag and $insideDEF => - [:y,last] := formatDeftranIf(a,b,c) - ['SEQ,:y,['exit,1,last]] - ['IF,a,b,c] - u is ['Union,:argl] => - ['Union,:[x for a in argl - | x := (STRINGP a => [":",INTERN a,'Branch]; formatDeftran(a,nil))]] - u is [op,:itl,body] and MEMQ(op,'(REPEAT COLLECT)) and - ([nitl,:nbody] := formatDeftranREPEAT(itl,body)) => - formatDeftran([op,:nitl,nbody],SEQflag) - u is [":",a,b] => [":",formatDeftran(a,nil),formatDeftran(markMacroTran(b),nil)] - u is ["DEF",:.] => formatCapsuleFunction(u) - u is [op,:argl]=>[formatDeftran(op,nil),:[formatDeftran(x,nil) for x in argl]] - u = 'nil => 'empty - u - -formatCapsuleFunction ["DEF",form,tlist,b,body] == - $insideDEF : local := true - ["DEF", formatDeftran(form,nil),tlist,b,formatDeftran(body,nil)] - -formatDeftranCapsule(l,x,SEQflag) == - $insideCAPSULE: local := true - formatDeftran(['SEQ,:l,['exit,1,x]],SEQflag) - -formatDeftranRepper([op,a],SEQflag) == - a is [op1,b] and MEMQ(op1,'(rep per)) => - op = op1 => formatDeftran(a,SEQflag) - formatDeftran(b,SEQflag) - a is ["::",b,t] => - b := formatDeftran(b,SEQflag) - t := formatDeftran(t,SEQflag) - a := ["::",b,t] - op = 'per and t = "$" or op = 'rep and t = 'Rep => a - [op,a] - a is ['SEQ,:r] => ['SEQ,:[formatSeqRepper(op,x) for x in r]] - a is ['IF,p,b,c] => - formatDeftran(['IF,p,[op,b],[op, c]], SEQflag) - a is ['LET,a,b] => formatDeftran(['LET,a,[op,b]],SEQflag) - a is ['not,[op,a,b]] and (op1 := LASSOC(op,$pspadRelationAlist)) => - formatDeftran [op1,a,b] - a is ['return,n,r] => - MEMQ(opOf r,'(true false)) => a - ['return,n,[op,formatDeftran(r,SEQflag)]] - a is ['error,:.] => a - [op,formatDeftran(a,SEQflag)] - -formatDeftranColon([op,a,t],SEQflag) == --op is one of : :: pretend @ - a := formatDeftran(a,SEQflag) - t := formatDeftran(t,SEQflag) - a is ["UNCOERCE",b] => b - a is [op1,b,t1] and t1 = t and MEMQ(op,'(_: _:_: _pretend _@)) => - op1 = "pretend" or op = "pretend" => ["pretend",b,t] - null SEQflag and op1 = ":" or op = ":" => ["pretend",b,t] - a - a is [=op,b,t1] => - t1 = t => a - [op,b,t] - t = "$" => - a is ['rep,b] => b - a is ['per,b] => a - [op,a,t] - t = "Rep" => - a is ['per,b] => b - a is ['rep,b] => a - [op,a,t] - [op,a,t] - -formatSeqRepper(op,x) == - x is ['exit,n,y] => ['exit,n,[op,formatDeftran(y,nil)]] - x is ["=>",a,b] => ["=>",formatDeftran(a,nil),[op,formatDeftran(b,nil)]] - atom x => x - [formatSeqRepper(op,y) for y in x] - -formatDeftranJoin(u,SEQflag) == - ['Join,:cats,lastcat] := u - lastcat is ['CATEGORY,kind,:l,x] => - cat := - CDR cats => ['Join,:cats] - first cats - formatDeftran(['with,cat,['SEQ,:l,['exit,1,x]]],SEQflag) - u - -formatENUM ['MyENUM, x] == format "'" and format x and format "'" - -formatDeftranREPEAT(itl,body) == ---do nothing unless "itl" contains UNTIL statements - u := [x for x in itl | x is ["UNTIL",p]] or return nil - nitl := SETDIFFERENCE(itl,u) - pred := MKPF([p for ['UNTIL,p] in u],'or) - cond := ['IF,pred,['leave,n,nil],'noBranch] - nbody := - body is ['SEQ,:l,[.,n,x]] => ['SEQ,:l,x,['exit,n,cond]] - ['SEQ,body,['exit,n,cond]] - [nitl,:nbody] - -formatDeftranSEQ(x,flag) == - u := formatDeftran(x,flag) - u is ['SEQ,:.] => rest u - [u] - -formatDeftranIf(a,b,c) == - b = 'noBranch => - a is [op,:r] and (al := '((_= . _~_=) (_< . _>_=) (_> . _<_=)); - iop := LASSOC(op, al) or rassoc(op, al)) => - [["=>",[iop, :r],c]] - a is [op,r] and MEMQ(op,'(NOT not NULL null)) => - [["=>", r, c]] - [["=>", ['not, a], c]] - post := - c = 'noBranch => nil - c is ['SEQ,:.] => CDR c - [c] - [["=>",a,b],:post] - -formatWHERE ["where",a,b] == - $insideTypeExpression: local := nil - $insideCAPSULE: local := false - tryBreak(formatLeft("format",a,"where","Led") and format " where ",b,"where","Led") - ---====================================================================== --- Special Handlers: Categories ---====================================================================== -formatATTRIBUTE ['ATTRIBUTE,att] == format att - -formatDeftranCategory ['CATEGORY,kind,:items,item] == ["SEQ",:items,["exit",1,item]] - -formatCategory ['Category] == format " " and format "Category" - -formatCATEGORY cat == - con := opOf $form - $comments: local := SUBST('_$,'_%,GETDATABASE(con,'DOCUMENTATION)) - $insideEXPORTS : local := true - format ["with",formatDeftranCategory cat] - -formatSIGNATURE ['SIGNATURE,op,types,:r] == - MEMQ('constant,r) => format op and format ": " and (u := format first types) and - formatSC() and formatComments(u,op,types) - format op and format ": " and (u := format ['Mapping,:types]) and formatSC() and - formatComments(u,op,types) - -formatDefault ["default",a] == - $insideCategoryIfTrue : local := false - $insideCAPSULE: local := true - $insideTypeExpression: local := false - tryBreak(format "default ",a,"with","Nud") ---====================================================================== --- Special Handlers: Control Structures ---====================================================================== -formatUNCOERCE ['UNCOERCE,x] == format x - -formatIF ['IF,a,b,c] == - c = 'noBranch => formatIF2(a,b,"if ") - b = 'noBranch => formatIF ['IF,['not,a],c,'noBranch] - formatIF2(a,b,"if ") and newLine() and formatIF3 c - -formatIF2(a,b,prefix) == - tryBreakNB(format prefix and format a and format " then ",b,"then","Nud") - -formatIF3 x == - x is ['IF,a,b,c] => - c = 'noBranch => tryBreak(format "else if " - and format a and format " then ",b,"then","Nud") - formatIF2(a,b,"else if ") and newLine() and formatIF3 c - tryBreak(format "else ",x,"else","Nud") - -formatBlock(l,x) == - null l => format x - $pilesAreOkHere: local - format "{ " and format first l and - (and/[formatSC() and format y for y in rest l]) - and formatSC() and format x and format " }" - -formatExit ["exit",.,u] == format u - -formatvoid ["void"] == format "()" - -formatLeave ["leave",.,u] == format "break" - -formatCOLLECT u == formatSpill("formatCOLLECT1",u) - -formatCOLLECT1 ["COLLECT",:iteratorList,body] == - $pilesAreOkHere: local - format "[" and format body and format " " and - formatSpill("formatIteratorTail",iteratorList) - -formatIteratorTail iteratorList == - formatIterator first iteratorList and - (and/[format " " and formatIterator x for x in rest iteratorList]) and format "]" - ---====================================================================== --- Special Handlers: Keywords ---====================================================================== - -formatColon [":",a,b] == - b is ['with,c,:d] => formatColonWith(a,c,d) - if not $insideTypeExpression then - insideCat() => nil - format - $insideDEF => "local " - "default " - op := - $insideCAPSULE and not $insideDEF => ": " - insideCat() => ": " - ":" - b := (atom b => b; markMacroTran b) - a is ['LISTOF,:c] => formatComma c and format ": " and formatLocal1 b - formatInfix(op,[a, b],formatOpBindingPower(":","Led","left"), - formatOpBindingPower(":","Led","right")) - -formatColonWith(form,a,b) == - con := opOf $form - $comments: local := SUBST('_$,'_%,GETDATABASE(con,'DOCUMENTATION)) - $insideEXPORTS : local := true - $pilesAreOkHere: local := true - $insideTypeExpression : local := false - b => tryBreak(formatDefForm form and format ": " - and format a and format " with ",first b,"with","Led") - tryBreak(formatDefForm form and format ": with ",a,"with","Nud") - -formatCOND ["COND",:l] == - originalC:= $c - and/[x is [a,[.,.,b]] for x in l] => - (originalC=$m or indent() and newLine()) and first l is [a,[.,.,b]] and - formatIfExit(a,b) and - (and/[newLine() and formatIfExit(a,b) for [a,[.,.,b]] in rest l]) and (originalC=$m or undent()) and originalC - formatIfThenElse l - -formatPROGN ["PROGN",:l] == - l is [:u,x] => formatPiles(u,x) - error '"formatPROGN" - -formatELT ["ELT",a,b] == formatApplication [a,b] - -formatCONS ["CONS",a,b] == - $pilesAreOkHere: local - format "[" and formatConstructItem a and formatTail b - -formatTail x == - null x => format "]" - format "," and formatTail1 x - -formatTail1 x == - x is ["CONS",a,b] => formatConstructItem a and formatTail b - x is ["APPEND",a,b] => - null b => formatConstructItem a and format "]" - format ":" and formatConstructItem a and formatTail b - format ":" and formatConstructItem x and format "]" - --- x = "." => format " " -formatConstructItem x == format x - -formatLET ["LET",a,b] == - $insideTypeExpression: local := true - a = "Rep" or atom a and constructor? opOf b => - tryBreakNB(formatAtom a and format " == ",b,":=","Led") - tryBreakNB((IDENTP a => formatAtom a; format a) and format " := ",b,":=","Led") - -formatIfExit(a,b) == - --called from SCOND or COND only - $numberOfSpills: local:= 0 - curMargin:= $m - curMarginStack:= $currentMarginStack - $doNotResetMarginIfTrue:= true - format a and format " => " and formatRight("formatCut",b,"=>","Led") => - ($currentMarginStack:= curMarginStack; $m:= curMargin) - -formatIfThenElse x == formatSpill("formatIf1",x) - -formatIf1 x == - x is [[a,:r],:c] and null c => - b:= - r is [:l,s] and l => ['SEQ,:l,['exit,.,s]] - first r - isTrue a => format b - format "if " and format a and format " then " and format b - format "if " and format a and - (try - (format " then " and format b and format " else " - and formatIfThenElse c) or spillLine() - and format " then " and format b and --- ($c:= $m:= $m+6) and - ($numberOfSpills:= $numberOfSpills-1) - and spillLine() and format " else " and formatIfThenElse c) - -formatQUOTE ["QUOTE",x] == format "('" and format x and format ")" - -formatMI ["MI",a,b] == format a - -formatMapping ['Mapping,target,:sources] == - $noColonDeclaration: local := true - formatTuple ['Tuple,:sources] and format " -> " and format target - -formatTuple ['Tuple,:types] == - null types => format "()" - null rest types => format first types - formatFunctionCallTail types - -formatConstruct(['construct,:u]) == - format "[" and (null u or format first u and - "and"/[format "," and formatCut x for x in rest u]) and format "]" - -formatNextConstructItem x == - try format x or ($m := $m + 2) and newLine() and format x - -formatREPEAT ["REPEAT",:iteratorList,body] == - tryBreakNB(null iteratorList or (formatIterator first iteratorList and - (and/[format " " and formatIterator x for x in rest iteratorList]) and format " ") - and format "repeat ",body,"repeat","Led") - -formatFATARROW ["=>",a,b] == tryBreak(format a and format " => ",b,"=>","Led") - -formatMap ["+->",a,b] == - $noColonDeclaration: local := true - tryBreak(format a and format " +-> ", b, "+->","Led") - -formatREDUCE ["REDUCE",op,.,u] == formatReduce1(op,u) - -formatreduce ["reduce",op,u] == formatReduce1(op,u) - -formatReduce1(op,u) == - if STRINGP op then op := INTERN op - id := LASSOC(op, - '((_+ Zero)(_* One)(append . NIL)(gcd Zero) (lcm One) (strconc . "")(lcm One))) - formatFunctionCall - id => ['reduce,op,u,id] - ['reduce,op,u] - -formatIterator u == - $noColonDeclaration : local := true - u is ["IN",x,y] => - format "for " and formatLeft("format",x,"in","Led") and format " in " and - formatRight("format",y,"in","Led") - u is ["WHILE",x] => format "while " and formatRight("format",x,"while","Nud") - u is ["UNTIL",x] => format "until " and formatRight("format",x,"until","Nud") - u is ["|",x] => format "| " and formatRight("format",x,"|","Led") - u is ["STEP",i,init,step,:v] => - final := IFCAR v - format "for " and formatLeft("format",i,"in","Led") and format " in " and - (seg := ['SEGMENT,init,final]) and (formatStepOne? step => format seg; formatBy ['by,seg,step]) - error "formatIterator" - -formatStepOne? step == - step = 1 or step = '(One) => true - step is [op,n,.] and MEMQ(op,'(_:_: _@)) => n = 1 or n = '(One) - false - -formatBy ['by,seg,step] == format seg and format " by " and format step - -formatSCOND ["SCOND",:l] == - $pilesAreOkHere => - --called from formatPileLine or formatBlock - --if from formatPileLine - initialC:= $c - and/[x is [a,["exit",.,b]] for x in l] => - first l is [a,["exit",.,b]] and formatIfExit(a,b) and - (and/[newLine() and formatIfExit(a,b) for [a,["exit",.,b]] in rest l]) and initialC - formatIfThenElse l and initialC - and/[x is [a,["exit",.,b]] for x in l] => - first l is [a,["exit",.,b]] and formatIfExit(a,b) and - (and/[format "; " and formatIfExit(a,b) for [a,["exit",.,b]] in rest l]) and $c - --warning: and/(...) returns T if there are no entries - formatIfThenElse l - -formatSEGMENT ["SEGMENT",a,b] == - $pilesAreOkHere: local - (if pspadBindingPowerOf("right",a)<750 then formatPren a else format a) and - formatInfixOp ".." and - (null b and $c or - (if 750>pspadBindingPowerOf("left",b) then formatPren b else format b)) - -formatSexpr x == - atom x => - null x or IDENTP x => consBuffer ident2PrintImage PNAME x - consBuffer x - spill("formatNonAtom",x) - -formatNonAtom x == - format "_(" and formatSexpr first x and - (and/[format " " and formatSexpr y for y in rest x]) - and (y:= LASTATOM x => format " . " - and formatSexpr y; true) and format "_)" - -formatCAPSULE ['CAPSULE,:l,x] == - $insideCAPSULE: local := true - try formatBlock(l,x) or formatPiles(l,x) or spillLine() and formatBlock(l,x) - -formatPAREN [.,:argl] == formatFunctionCallTail argl - -formatSEQ ["SEQ",:l,[.,.,x]] == - try formatBlock(l,x) or formatPiles(l,x) or spillLine() and formatBlock(l,x) - ---====================================================================== --- Comment Handlers ---====================================================================== -formatCOMMENT ["COMMENT",x,marg,startXY,endXY,commentStack] == - $commentsToPrint:= [[marg,startXY,endXY,commentStack],:$commentsToPrint] - format x - -formatComments(u,op,types) == - $numberOfSpills :local := $commentIndentation/2 - 1 - not $insideEXPORTS => u - alist := LASSOC(op,$comments) or - sayBrightly ['"No documentation for ",op] - return u - ftypes := SUBLISLIS($FormalMapVariableList,rest $form,types) - consComments(LASSOC(ftypes,alist),'"++ ") - u - -consComments(s,plusPlus) == - s is [word,:r] and null atom r => consComments(r, plusPlus) - s := first s - null s => nil - s := consCommentsTran s - indent() and newLine() or return nil - columnsLeft := $lineLength - $m - 2 - while (m := MAXINDEX s) >= columnsLeft repeat - k := or/[i for i in (columnsLeft - 1)..1 by -1 | s.i = $charBlank] - k := (k => k + 1; columnsLeft) - piece := SUBSTRING(s,0,k) - formatDoCommentLine [plusPlus,piece] - s := SUBSTRING(s,k,nil) - formatDoCommentLine [plusPlus,s] - undent() - $m - -consCommentsTran s == - m := MAXINDEX s - k := or/[i for i in 0..(m - 7) | substring?('"\spad{",s,i)] => - r := charPosition(char '_},s,k + 6) - r = m + 1 => s - STRCONC(SUBSTRING(s,0,k),'"`",SUBSTRING(s,k+6,r-k-6),'"'",consCommentsTran SUBSTRING(s,r+1,nil)) - s - -formatDoCommentLine line == - $lineBuffer := consLineBuffer [nBlanks $c,:line] - $c := $m+2*$numberOfSpills - ---====================================================================== --- Pile Handlers ---====================================================================== -formatPreferPile y == - y is ["SEQ",:l,[.,.,x]] => - (u:= formatPiles(l,x)) => u - formatSpill("format",y) - formatSpill("format",y) - -formatPiles(l,x) == - $insideTypeExpression : local := false - not $pilesAreOkHere => nil - originalC:= $c - lines:= [:l,x] - --piles must begin at margin - originalC=$m or indent() and newLine() or return nil - null (formatPileLine($m,first lines,false)) => nil - not (and/[formatPileLine($m,y,true) for y in rest lines]) => nil - (originalC=$m or undent()) and originalC --==> brace - -formatPileLine($m,x,newLineIfTrue) == - if newLineIfTrue then newLine() or return nil - $numberOfSpills: local:= 0 - $newLineWritten := nil - format x and (x is ['SIGNATURE,:.] or $rightBraceFlag => $c; formatSC()) - and (x is ['DEF,:.] and optNewLine() or $c) - ---====================================================================== --- Utility Functions ---====================================================================== -nBlanks m == "STRCONC"/[char('_ ) for i in 1..m] - -isNewspadOperator op == GET(op,"Led") or GET(op,"Nud") - -isTrue x == x="true" or x is '(QUOTE T) - -nary2Binary(u,op) == - u is [a,b,:t] => (t => nary2Binary([[op,a,b],:t],op); [op,a,b]) - errhuh() - -string2PrintImage s == - u:= GETSTR (2*SIZE s) - for i in 0..MAXINDEX s repeat - (if MEMQ(s.i,'(_( _{ _) _} _! _")) then - SUFFIX('__,u); u:= SUFFIX(s.i,u)) - u - -ident2PrintImage s == - m := MAXINDEX s - if m > 1 and s.(m - 1) = $underScore then s := STRCONC(SUBSTRING(s,0,m-1),s.m) - u:= GETSTR (2*SIZE s) - if not (ALPHA_-CHAR_-P s.(0) or s.(0)=char '"$") then SUFFIX('__,u) - u:= SUFFIX(s.(0),u) - for i in 1..MAXINDEX s repeat - if not (DIGITP s.i or ALPHA_-CHAR_-P s.i or ((c := s.i) = char '?) - or (c = char '_!)) then SUFFIX('__,u) - u:= SUFFIX(s.i,u) - INTERN u - -isIdentifier x == - IDENTP x => - s:= PNAME x - #s = 0 => nil - ALPHA_-CHAR_-P s.(0) => and/[s.i^=char '" " for i in 1..MAXINDEX s] - #s>1 => - or/[ALPHA_-CHAR_-P s.i for i in 1..(m:= MAXINDEX s)] => - and/[s.i^=char '" " for i in 1..m] => true - -isGensym x == - s := STRINGIMAGE x - n := MAXINDEX s - s.0 = char '_G and and/[DIGITP s.i for i in 1..n] - ---====================================================================== --- Macro Helpers ---====================================================================== -tryToFit(s,x) == ---% try to format on current line; see macro try in file PSPADAUX LISP - --returns nil if unable to format stuff in x on a single line - x => ($back:= rest $back; $c) - restoreState() - nil - -restoreState(:options) == - back := IFCAR options or $back - [ - [$lineBuffer, $lineFragmentBuffer,$comments,$marginStack,$braceStack,$DEFdepth, - $bc,$c,$m,$commentsToPrint,$numberOfSpills,flags], :back] - := back - if null options then $back := back - [$newLineWritten, $autoLine, $rightBraceFlag, - $semicolonFlag,$insideDEF,$insideTypeExpression,$pilesAreOkHere, - $insideEXPORTS, $insideCAPSULE, $insideCategoryIfTrue, - $doNotResetMarginIfTrue,$noColonDeclaration] - := flags - nil - -saveState(:options) == - flags := - [$newLineWritten, $autoLine, $rightBraceFlag, - $semicolonFlag,$insideDEF,$insideTypeExpression,$pilesAreOkHere, - $insideEXPORTS, $insideCAPSULE, $insideCategoryIfTrue, - $doNotResetMarginIfTrue,$noColonDeclaration] - newState := - [ - [$lineBuffer, $lineFragmentBuffer,$comments,$marginStack,$braceStack,$DEFdepth, - $bc,$c,$m,$commentsToPrint,$numberOfSpills,flags], :$back] - if not KAR options then $back := newState - newState - -formatSC() == - $pileStyle or $semicolonFlag => $c - format "; " - -wrapBraces(x,y,z) == y - -formatLB() == - $pileStyle => $c - $numberOfSpills := - $c > $lineLength / 2 => $braceIndentation/3 - 1 - $braceIndentation/2 - 1 - format "{" - -restoreC() == --used by macro "embrace" - originalC := CAR $braceStack - $braceStack := CDR $braceStack - formatRB originalC - -saveC() == --used by macro "embrace" - $braceStack := [$c,:$braceStack] - -saveD() == --used by macro "embrace" - $braceStack := [$c,:$braceStack] - -restoreD() == --used by macro "indentNB" - originalC := CAR $braceStack - $braceStack := CDR $braceStack - originalC - -formatRB(originalC) == --called only by restoreC - while $marginStack and $m > originalC repeat undent() - if $m < originalC then $marginStack := [originalC,:$marginStack] - $m := originalC - $pileStyle => $m - newLine() and format "}" and $m --==> brace - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/ptrees.boot b/src/interp/ptrees.boot new file mode 100644 index 00000000..b6ab6e37 --- /dev/null +++ b/src/interp/ptrees.boot @@ -0,0 +1,772 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- 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. + + + +-- This file provides functions to create and examine abstract +-- syntax trees. These are called pform, for short. +-- The definition of valid pforms see ABSTRACT BOOT. + +-- !! This file also contains constructors for concrete syntax, although +-- !! they should be somewhere else. + +-- THE PFORM DATA STRUCTURE +-- Leaves: [hd, tok, pos] +-- Trees: [hd, tree, tree, ...] +-- hd is either an id or (id . alist) + + + +import '"posit" +import '"serror" + +)package "BOOT" + +--% SPECIAL NODES +pfListOf x == pfTree('listOf,x) +pfListOf? x == pfAbSynOp?(x,'listOf) +pfAppend list == APPLY(function APPEND,list) + +pfNothing () == pfTree('nothing, []) +pfNothing? form == pfAbSynOp?(form, 'nothing) + +-- SemiColon + +pfSemiColon(pfbody) == pfTree('SemiColon, [pfbody]) +pfSemiColon?(pf) == pfAbSynOp? (pf, 'SemiColon) +pfSemiColonBody pf == CADR pf -- was ==> + +--% LEAVES +pfId(expr) == pfLeaf('id, expr) +pfIdPos(expr,pos) == pfLeaf('id,expr,pos) +pfId? form == + pfAbSynOp?(form,'id) or pfAbSynOp?(form,'idsy) +pfSymbolVariable? form == pfAbSynOp?(form,'idsy) +pfIdSymbol form == tokPart form +--pfAmpersand(amptok,name) == name + +pfDocument strings == pfLeaf('Document, strings) +pfDocument? form == pfAbSynOp?(form, 'Document) +pfDocumentText form == tokPart form + +pfLiteral? form == + MEMQ(pfAbSynOp form,'(integer symbol expression + one zero char string float)) + +pfLiteralClass form == pfAbSynOp form +pfLiteralString form == tokPart form + +pfStringConstString form == tokPart form + +pfExpression(expr, :optpos) == + pfLeaf("expression", expr, IFCAR optpos) +pfExpression? form == pfAbSynOp?(form, 'expression) + +pfSymbol(expr, :optpos) == + pfLeaf("symbol", expr, IFCAR optpos) + +pfSymb(expr, :optpos) == + if pfLeaf? expr + then pfSymbol(tokPart expr,IFCAR optpos) + else pfExpression(pfSexpr expr,IFCAR optpos) + +pfSymbol? form == pfAbSynOp?(form, 'symbol) + +pfSymbolSymbol form == tokPart form + +--% TREES +-- parser interface functions +-- these are potential sources of trouble in macro expansion + +-- the comment is attached to all signatutres +pfWDec(doc,name) == [pfWDeclare(i,doc) for i in pfParts name] + +pfTweakIf form== + a:=pfIfElse form + b:=if pfNothing? a then pfListOf [] else a + pfTree('WIf,[pfIfCond form,pfIfThen form,b]) + +pfInfApplication(op,left,right)== + pfCheckInfop left => + pfWrong(pfDocument ['"infop as argument to infop"],pfListOf []) + pfCheckInfop right => + pfWrong(pfDocument ['"infop as argument to infop"],pfListOf []) + EQ(pfIdSymbol op,"and")=> pfAnd (left,right) + EQ(pfIdSymbol op, "or")=> pfOr (left,right) + pfApplication(op,pfTuple pfListOf [left,right]) + +pfCheckInfop form== false + +pfAnd(pfleft, pfright) == pfTree('And, [pfleft, pfright]) +pfAnd?(pf) == pfAbSynOp? (pf, 'And) +pfAndLeft pf == CADR pf -- was ==> +pfAndRight pf == CADDR pf -- was ==> + +pfOr(pfleft, pfright) == pfTree('Or, [pfleft, pfright]) +pfOr?(pf) == pfAbSynOp? (pf, 'Or) +pfOrLeft pf == CADR pf -- was ==> +pfOrRight pf == CADDR pf -- was ==> + +pfNot(arg) == pfTree('Not, [arg]) +pfNot?(pf) == pfAbSynOp? (pf, 'Not) +pfNotArg pf == CADR pf -- was ==> + +pfEnSequence a== + if null a + then pfTuple pfListOf a + else if null cdr a + then car a + else pfSequence pfListOf a +pfFromDom(dom,expr)== + if pfApplication? expr + then pfApplication(pfFromdom(pfApplicationOp expr,dom), + pfApplicationArg expr) + else pfFromdom(expr,dom) + +pfReturnTyped(type,body)==pfTree('returntyped,[type,body]) + +pfLam(variable,body)==-- called from parser + rets:= if pfAbSynOp?(body,'returntyped) + then pfFirst body + else pfNothing () + bdy:= if pfAbSynOp?(body,'returntyped) then pfSecond body else body + pfLambda(variable,rets,bdy) + +pfTLam(variable,body)==-- called from parser + rets:= if pfAbSynOp?(body,'returntyped) + then pfFirst body + else pfNothing () + bdy:= if pfAbSynOp?(body,'returntyped) then pfSecond body else body + pfTLambda(variable,rets,bdy) + +pfIfThenOnly(pred,first)==pfIf(pred,first,pfNothing()) + +pfLp(iterators,body)== + pfLoop pfListOf [:iterators,pfDo body] +pfLoop1 body == pfLoop pfListOf [pfDo body] + + +pfExitNoCond value== pfExit(pfNothing(),value) + +pfReturnNoName(value)==pfReturn(value,pfNothing()) + +pfBrace(a,part)==pfApplication(pfIdPos( "{}",tokPosn a),part) + +pfBracket(a,part) == pfApplication(pfIdPos( "[]",tokPosn a),part) +pfBraceBar(a,part)==pfApplication(pfIdPos( "{||}",tokPosn a),part) + +pfBracketBar(a,part) == pfApplication(pfIdPos( "[||]",tokPosn a),part) +pfHide(a,part) == pfTree("Hide",[part]) +pfHide? x== pfAbSynOp?(x,"Hide") +pfHidePart x== CADR x +pfParen(a,part)==part + +pfPile(part)==part + +pfSpread(l,t)== [pfTyped(i,t) for i in l] + +pfTupleList form== pfParts pfTupleParts form + +--The rest have been generated from ABCUT INPUT +-- 1/31/89 + + +-- Add / Application / Assign / +-- Coerceto / Collect / ComDefinition / DeclPart / +-- Exit / Export / Free / +-- Fromdom / Id / If / Inline / +-- Iterate / Lambda / +-- Break / Literal / Local / Loop / +-- MLambda / Pretend / Restrict / Return / +-- Sequence / Tagged / Tuple / Typing / +-- Where / With + +pfExpr? pf == + pfAdd? pf or _ + pfApplication? pf or _ + pfAssign? pf or _ + pfCoerceto? pf or _ + pfCollect? pf or _ + pfComDefinition? pf or _ + pfDeclPart? pf or _ + pfExit? pf or _ + pfExport? pf or _ + pfFree? pf or _ + pfFromdom? pf or _ + pfId? pf or _ + pfIf? pf or _ + pfInline? pf or _ + pfIterate? pf or _ + pfLambda? pf or _ + pfBreak? pf or _ + pfLiteral? pf or _ + pfLocal? pf or _ + pfLoop? pf or _ + pfMLambda? pf or _ + pfPretend? pf or _ + pfRestrict? pf or _ + pfReturn? pf or _ + pfTagged? pf or _ + pfTuple? pf or _ + pfWhere? pf or _ + pfWith? pf + + +pfDeclPart? pf == + pfTyping? pf or _ + pfImport? pf or _ + pfDefinition? pf or _ + pfSequence? pf or _ + pfDWhere? pf or _ + pfMacro? pf + + +-- Wrong := (Why: Document, Rubble: [Expr]) + +pfWrong(pfwhy, pfrubble) == pfTree('Wrong, [pfwhy, pfrubble]) +pfWrong?(pf) == pfAbSynOp? (pf, 'Wrong) +pfWrongWhy pf == CADR pf -- was ==> +pfWrongRubble pf == CADDR pf -- was ==> +pf0WrongRubble pf == pfParts pfWrongRubble pf + + +-- Add := (Base: [Typed], Addin: Expr) + +pfAdd(pfbase, pfaddin,:addon) == + lhs := if addon + then first addon + else pfNothing() + pfTree('Add, [pfbase, pfaddin,lhs]) + +pfAdd?(pf) == pfAbSynOp? (pf, 'Add) +pfAddBase pf == CADR pf -- was ==> +pfAddAddin pf == CADDR pf -- was ==> +pfAddAddon pf == CADDDR pf -- was ==> +pf0AddBase pf == pfParts pfAddBase pf + + + +-- DWhere := (Context: [DeclPart], Expr: [DeclPart]) + +pfDWhere(pfcontext, pfexpr) == pfTree('DWhere, [pfcontext, pfexpr]) +pfDWhere?(pf) == pfAbSynOp? (pf, 'DWhere) +pfDWhereContext pf == CADR pf -- was ==> +pfDWhereExpr pf == CADDR pf -- was ==> + + + +-- With := (Base: [Typed], Within: [WithPart]) + +pfWith(pfbase, pfwithin,pfwithon) == + pfTree('With, [pfbase, pfwithin,pfwithon]) +pfWith?(pf) == pfAbSynOp? (pf, 'With) +pfWithBase pf == CADR pf -- was ==> +pfWithWithin pf == CADDR pf -- was ==> +pfWithWithon pf == CADDDR pf -- was ==> +pf0WithBase pf == pfParts pfWithBase pf +pf0WithWithin pf == pfParts pfWithWithin pf + + +-- WIf := (Cond: Primary, Then: [WithPart], Else: [WithPart]) + +pfWIf(pfcond, pfthen, pfelse) == pfTree('WIf, [pfcond, pfthen, pfelse]) +pfWIf?(pf) == pfAbSynOp? (pf, 'WIf) +pfWIfCond pf == CADR pf -- was ==> +pfWIfThen pf == CADDR pf -- was ==> +pfWIfElse pf == CADDDR pf -- was ==> + +-- WDeclare := (Signature: Typed, Doc: ? Document) + +pfWDeclare(pfsignature, pfdoc) == pfTree('WDeclare, [pfsignature, _ +pfdoc]) +pfWDeclare?(pf) == pfAbSynOp? (pf, 'WDeclare) +pfWDeclareSignature pf == CADR pf -- was ==> +pfWDeclareDoc pf == CADDR pf -- was ==> + + +-- Attribute := (Expr: Primary) + +pfAttribute(pfexpr) == pfTree('Attribute, [pfexpr]) +pfAttribute?(pf) == pfAbSynOp? (pf, 'Attribute) +pfAttributeExpr pf == CADR pf -- was ==> + + +-- Typed := (Id: Id, Type: ? Type) + +pfTyped(pfid, pftype) == pfTree('Typed, [pfid, pftype]) +pfTyped?(pf) == pfAbSynOp? (pf, 'Typed) +pfTypedId pf == CADR pf -- was ==> +pfTypedType pf == CADDR pf -- was ==> + + +-- Application := (Op: Expr, Arg: Expr) + +pfApplication(pfop, pfarg) == + pfTree('Application, [pfop, pfarg]) + +pfApplication?(pf) == pfAbSynOp? (pf, 'Application) +pfApplicationOp pf == CADR pf -- was ==> +pfApplicationArg pf == CADDR pf -- was ==> + + +-- Tuple := (Parts: [Expr]) + +pfTupleListOf(pfparts) == pfTuple pfListOf pfparts +pfTuple(pfparts) == pfTree('Tuple, [pfparts]) +pfTuple?(pf) == pfAbSynOp? (pf, 'Tuple) +pfTupleParts pf == CADR pf -- was ==> +pf0TupleParts pf == pfParts pfTupleParts pf + + +-- Tagged := (Tag: Expr, Expr: Expr) + +pfTagged(pftag, pfexpr) == pfTree('Tagged, [pftag, pfexpr]) +pfTagged?(pf) == pfAbSynOp? (pf, 'Tagged) +pfTaggedTag pf == CADR pf -- was ==> +pfTaggedExpr pf == CADDR pf -- was ==> + + +-- Pretend := (Expr: Expr, Type: Type) + +pfPretend(pfexpr, pftype) == pfTree('Pretend, [pfexpr, pftype]) +pfPretend?(pf) == pfAbSynOp? (pf, 'Pretend) +pfPretendExpr pf == CADR pf -- was ==> +pfPretendType pf == CADDR pf -- was ==> + + +-- Restrict := (Expr: Expr, Type: Type) + +pfRestrict(pfexpr, pftype) == pfTree('Restrict, [pfexpr, pftype]) +pfRestrict?(pf) == pfAbSynOp? (pf, 'Restrict) +pfRestrictExpr pf == CADR pf -- was ==> +pfRestrictType pf == CADDR pf -- was ==> + +pfRetractTo(pfexpr, pftype) == pfTree('RetractTo, [pfexpr, pftype]) +pfRetractTo?(pf) == pfAbSynOp? (pf, 'RetractTo) +pfRetractToExpr pf == CADR pf -- was ==> +pfRetractToType pf == CADDR pf -- was ==> + + +-- Coerceto := (Expr: Expr, Type: Type) + +pfCoerceto(pfexpr, pftype) == pfTree('Coerceto, [pfexpr, pftype]) +pfCoerceto?(pf) == pfAbSynOp? (pf, 'Coerceto) +pfCoercetoExpr pf == CADR pf -- was ==> +pfCoercetoType pf == CADDR pf -- was ==> + + +-- Fromdom := (What: Id, Domain: Type) + +pfFromdom(pfwhat, pfdomain) == pfTree('Fromdom, [pfwhat, pfdomain]) +pfFromdom?(pf) == pfAbSynOp? (pf, 'Fromdom) +pfFromdomWhat pf == CADR pf -- was ==> +pfFromdomDomain pf == CADDR pf -- was ==> + + +-- Lambda := (Args: [Typed], Rets: ? Type, Body: Expr) + +pfLambda(pfargs, pfrets, pfbody) == pfTree('Lambda, [pfargs, pfrets, _ +pfbody]) +pfLambda?(pf) == pfAbSynOp? (pf, 'Lambda) +pfLambdaArgs pf == CADR pf -- was ==> +pfLambdaRets pf == CADDR pf -- was ==> +pfLambdaBody pf == CADDDR pf -- was ==> +pf0LambdaArgs pf == pfParts pfLambdaArgs pf +pfFix pf== pfApplication(pfId "Y",pf) + + +-- TLambda := (Args: [Typed], Rets: ? Type, Body: Expr) + +pfTLambda(pfargs, pfrets, pfbody) == pfTree('TLambda, [pfargs, pfrets, pfbody]) +pfTLambda?(pf) == pfAbSynOp? (pf, 'TLambda) +pfTLambdaArgs pf == CADR pf -- was ==> +pfTLambdaRets pf == CADDR pf -- was ==> +pfTLambdaBody pf == CADDDR pf -- was ==> +pf0TLambdaArgs pf == pfParts pfTLambdaArgs pf + + +-- MLambda := (Args: [Id], Body: Expr) + +pfMLambda(pfargs, pfbody) == pfTree('MLambda, [pfargs, pfbody]) +pfMLambda?(pf) == pfAbSynOp? (pf, 'MLambda) +pfMLambdaArgs pf == CADR pf -- was ==> +pfMLambdaBody pf == CADDR pf -- was ==> +pf0MLambdaArgs pf == pfParts pfMLambdaArgs pf + + +-- Where := (Context: [DeclPart], Expr: Expr) + +pfWhere(pfcontext, pfexpr) == pfTree('Where, [pfcontext, pfexpr]) +pfWhere?(pf) == pfAbSynOp? (pf, 'Where) +pfWhereContext pf == CADR pf -- was ==> +pfWhereExpr pf == CADDR pf -- was ==> +pf0WhereContext pf == pfParts pfWhereContext pf + + +-- If := (Cond: Expr, Then: Expr, Else: ? Expr) + +pfIf(pfcond, pfthen, pfelse) == pfTree('If, [pfcond, pfthen, pfelse]) +pfIf?(pf) == pfAbSynOp? (pf, 'If) +pfIfCond pf == CADR pf -- was ==> +pfIfThen pf == CADDR pf -- was ==> +pfIfElse pf == CADDDR pf -- was ==> + + +-- Sequence := (Args: [Expr]) + +pfSequence(pfargs) == pfTree('Sequence, [pfargs]) +pfSequence?(pf) == pfAbSynOp? (pf, 'Sequence) +pfSequenceArgs pf == CADR pf -- was ==> +pf0SequenceArgs pf == pfParts pfSequenceArgs pf + + +-- Novalue := (Expr: Expr) + +pfNovalue(pfexpr) == pfTree('Novalue, [pfexpr]) +pfNovalue?(pf) == pfAbSynOp? (pf, 'Novalue) +pfNovalueExpr pf == CADR pf -- was ==> + + +-- Loop := (Iterators: [Iterator]) + +pfLoop(pfiterators) == pfTree('Loop, [pfiterators]) +pfLoop?(pf) == pfAbSynOp? (pf, 'Loop) +pfLoopIterators pf == CADR pf -- was ==> +pf0LoopIterators pf == pfParts pfLoopIterators pf + + +-- Collect := (Body: Expr, Iterators: [Iterator]) + +pfCollect(pfbody, pfiterators) == pfTree('Collect, [pfbody, _ +pfiterators]) +pfCollect?(pf) == pfAbSynOp? (pf, 'Collect) +pfCollectBody pf == CADR pf -- was ==> +pfCollectIterators pf == CADDR pf -- was ==> +pf0CollectIterators pf == pfParts pfCollectIterators pf + + +-- Forin := (Lhs: [AssLhs], Whole: Expr) + +pfForin(pflhs, pfwhole) == pfTree('Forin, [pflhs, pfwhole]) +pfForin?(pf) == pfAbSynOp? (pf, 'Forin) +pfForinLhs pf == CADR pf -- was ==> +pfForinWhole pf == CADDR pf -- was ==> +pf0ForinLhs pf == pfParts pfForinLhs pf + + +-- While := (Cond: Expr) + +pfWhile(pfcond) == pfTree('While, [pfcond]) +pfWhile?(pf) == pfAbSynOp? (pf, 'While) +pfWhileCond pf == CADR pf -- was ==> + + +-- Until := (Cond: Expr) + +--pfUntil(pfcond) == pfTree('Until, [pfcond]) +--pfUntil?(pf) == pfAbSynOp? (pf, 'Until) +--pfUntilCond pf == CADR pf -- was ==> + + +-- Suchthat := (Cond: Expr) + +pfSuchthat(pfcond) == pfTree('Suchthat, [pfcond]) +pfSuchthat?(pf) == pfAbSynOp? (pf, 'Suchthat) +pfSuchthatCond pf == CADR pf -- was ==> + + +-- Do := (Body: Expr) + +pfDo(pfbody) == pfTree('Do, [pfbody]) +pfDo?(pf) == pfAbSynOp? (pf, 'Do) +pfDoBody pf == CADR pf -- was ==> + + +-- Iterate := (From: ? Id) + +pfIterate(pffrom) == pfTree('Iterate, [pffrom]) +pfIterate?(pf) == pfAbSynOp? (pf, 'Iterate) +pfIterateFrom pf == CADR pf -- was ==> + + +-- Break := (From: ? Id) + +pfBreak(pffrom) == pfTree('Break, [pffrom]) +pfBreak?(pf) == pfAbSynOp? (pf, 'Break) +pfBreakFrom pf == CADR pf -- was ==> + + +-- Return := (Expr: ? Expr, From: ? Id) + +pfReturn(pfexpr, pffrom) == pfTree('Return, [pfexpr, pffrom]) +pfReturn?(pf) == pfAbSynOp? (pf, 'Return) +pfReturnExpr pf == CADR pf -- was ==> +pfReturnFrom pf == CADDR pf -- was ==> + + +-- Exit := (Cond: ? Expr, Expr: ? Expr) + +pfExit(pfcond, pfexpr) == pfTree('Exit, [pfcond, pfexpr]) +pfExit?(pf) == pfAbSynOp? (pf, 'Exit) +pfExitCond pf == CADR pf -- was ==> +pfExitExpr pf == CADDR pf -- was ==> + + +-- Macro := (Lhs: Id, Rhs: ExprorNot) + +pfMacro(pflhs, pfrhs) == pfTree('Macro, [pflhs, pfrhs]) +pfMacro?(pf) == pfAbSynOp? (pf, 'Macro) +pfMacroLhs pf == CADR pf -- was ==> +pfMacroRhs pf == CADDR pf -- was ==> + + +-- Definition := (LhsItems: [Typed], Rhs: Expr) + +pfDefinition(pflhsitems, pfrhs) == pfTree('Definition, [pflhsitems, pfrhs]) +pfDefinition?(pf) == pfAbSynOp? (pf, 'Definition) +pfDefinitionLhsItems pf == CADR pf -- was ==> +pfDefinitionRhs pf == CADDR pf -- was ==> +pf0DefinitionLhsItems pf == pfParts pfDefinitionLhsItems pf + +pfRule(pflhsitems, pfrhs) == pfTree('Rule, [pflhsitems, _ +pfrhs]) +pfRule?(pf) == pfAbSynOp? (pf, 'Rule) +pfRuleLhsItems pf == CADR pf -- was ==> +pfRuleRhs pf == CADDR pf -- was ==> + +-- ComDefinition := (Doc:Document,Def:Definition) + +pfComDefinition(pfdoc, pfdef) == pfTree('ComDefinition, [pfdoc, pfdef] ) +pfComDefinition?(pf) == pfAbSynOp? (pf, 'ComDefinition) +pfComDefinitionDoc pf == CADR pf -- was ==> +pfComDefinitionDef pf == CADDR pf -- was ==> + + +-- DefinitionSequence := (Args: [DeclPart]) + +pfDefinitionSequenceArgs pf == CADR pf -- was ==> + +-- Export := (Def: Definition) + +pfExportDef pf == CADR pf -- was ==> + +-- Assign := (LhsItems: [AssLhs], Rhs: Expr) + +pfAssign(pflhsitems, pfrhs) == pfTree('Assign, [pflhsitems, pfrhs]) +pfAssign?(pf) == pfAbSynOp? (pf, 'Assign) +pfAssignLhsItems pf == CADR pf -- was ==> +pfAssignRhs pf == CADDR pf -- was ==> +pf0AssignLhsItems pf == pfParts pfAssignLhsItems pf + + +-- Typing := (Items: [Typed]) + +pfTyping(pfitems) == pfTree('Typing, [pfitems]) +pfTyping?(pf) == pfAbSynOp? (pf, 'Typing) +pfTypingItems pf == CADR pf -- was ==> +pf0TypingItems pf == pfParts pfTypingItems pf + + +-- Export := (Items: [Typed]) + +pfExport(pfitems) == pfTree('Export, [pfitems]) +pfExport?(pf) == pfAbSynOp? (pf, 'Export) +pfExportItems pf == CADR pf -- was ==> +pf0ExportItems pf == pfParts pfExportItems pf + + +-- Local := (Items: [Typed]) + +pfLocal(pfitems) == pfTree('Local, [pfitems]) +pfLocal?(pf) == pfAbSynOp? (pf, 'Local) +pfLocalItems pf == CADR pf -- was ==> +pf0LocalItems pf == pfParts pfLocalItems pf + +-- Free := (Items: [Typed]) + +pfFree(pfitems) == pfTree('Free, [pfitems]) +pfFree?(pf) == pfAbSynOp? (pf, 'Free) +pfFreeItems pf == CADR pf -- was ==> +pf0FreeItems pf == pfParts pfFreeItems pf + + +-- Import := (Items: [QualType]) + +pfImport(pfitems) == pfTree('Import, [pfitems]) +pfImport?(pf) == pfAbSynOp? (pf, 'Import) +pfImportItems pf == CADR pf -- was ==> +pf0ImportItems pf == pfParts pfImportItems pf + + +-- Inline := (Items: [QualType]) + +pfInline(pfitems) == pfTree('Inline, [pfitems]) +pfInline?(pf) == pfAbSynOp? (pf, 'Inline) +pfInlineItems pf == CADR pf -- was ==> + +-- QualType := (Type: Type, Qual: ? Type) + +pfQualType(pftype, pfqual) == pfTree('QualType, [pftype, pfqual]) +pfQualType?(pf) == pfAbSynOp? (pf, 'QualType) +pfQualTypeType pf == CADR pf -- was ==> +pfQualTypeQual pf == CADDR pf -- was ==> + +pfSuch(x,y)== pfInfApplication(pfId "|",x,y) + +pfTaggedToTyped x== + rt:=if pfTagged? x then pfTaggedExpr x else pfNothing() + form:= if pfTagged? x then pfTaggedTag x else x + not pfId? form => + a:=pfId GENSYM() + pfTyped(pfSuch(a, + pfInfApplication (pfId "=", a,form)),rt) + pfTyped(form,rt) + +pfTaggedToTyped1 x== + pfCollect1? x => pfCollectVariable1 x + pfDefinition? x => pfTyped(x,pfNothing()) + pfTaggedToTyped x + +pfCollectVariable1 x== + a := pfApplicationArg x + var:=first pf0TupleParts a + id:=pfTaggedToTyped var + pfTyped(pfSuch(pfTypedId id,CADR pf0TupleParts a), + pfTypedType id) + +pfPushBody(t,args,body)== + if null args + then body + else if null rest args + then pfLambda(first args,t,body) + else + pfLambda(first args,pfNothing(), + pfPushBody(t,rest args,body)) + +pfCheckItOut x == + rt:=if pfTagged? x then pfTaggedExpr x else pfNothing() + form:= if pfTagged? x then pfTaggedTag x else x + pfId? form => [pfListOf [pfTyped(form,rt)],nil,rt] + pfCollect1? form => + [pfListOf [pfCollectVariable1 form],nil,rt] + pfTuple? form => + [pfListOf [pfTaggedToTyped i for i in pf0TupleParts form],nil,rt] + pfDefinition? form => + [pfListOf [pfTyped(form,pfNothing())],nil,rt] + pfApplication? form => + ls:=pfFlattenApp form + op:= pfTaggedToTyped1 first ls + args:=[pfTransformArg i for i in rest ls] + [pfListOf [op],args,rt] + npTrapForm form + +pfCollect1? x== + pfApplication? x => + a:=pfApplicationOp x + pfId? a => pfIdSymbol a = "|" + false + false + +pfTransformArg args== + argl:= if pfTuple? args then pf0TupleParts args else [args] + pfListOf [pfTaggedToTyped1 i for i in argl] + + +pfCheckMacroOut form == + pfId? form => [form,nil] + pfApplication? form => + ls:=pfFlattenApp form + op:= pfCheckId first ls + args:=[pfCheckArg i for i in rest ls] + [op,args] + npTrapForm form + +pfCheckArg args== + argl:= if pfTuple? args then pf0TupleParts args else [args] + pfListOf [pfCheckId i for i in argl] + +pfCheckId form== if not pfId? form then npTrapForm(form) else form + +pfPushMacroBody(args,body)== + null args => body + pfMLambda(first args,pfPushMacroBody(rest args,body)) + +pfFlattenApp x== + pfApplication? x=> + pfCollect1? x =>[ x ] + append (pfFlattenApp pfApplicationOp x, + pfFlattenApp pfApplicationArg x) + [x] + + +--% Utility operations on Abstract Syntax Trees + +-- An S-expression which people can read. +pfSexpr pform == + strip pform where + strip pform == + pfId? pform => pfIdSymbol pform + pfLiteral? pform => pfLiteralString pform + pfLeaf? pform => tokPart pform + + pfApplication? pform => + args := + a := pfApplicationArg pform + if pfTuple? a then pf0TupleParts a else [a] + [strip p for p in cons(pfApplicationOp pform, args)] + + cons(pfAbSynOp pform, [strip p for p in pfParts pform]) + +pfCopyWithPos( pform , pos ) == + pfLeaf? pform => pfLeaf( pfAbSynOp pform , tokPart pform , pos ) + pfTree( pfAbSynOp pform , [ pfCopyWithPos( p , pos ) for p in pfParts pform ] ) + +pfMapParts(f, pform) == + pfLeaf? pform => pform + parts0 := pfParts pform + parts1 := [FUNCALL(f, p) for p in parts0] + -- Return the original if no changes. + same := true + for p0 in parts0 for p1 in parts1 while same repeat same := EQ(p0,p1) + same => pform + pfTree(pfAbSynOp pform, parts1) + + +pf0ApplicationArgs pform == + arg := pfApplicationArg pform + pf0FlattenSyntacticTuple arg + +pf0FlattenSyntacticTuple pform == + not pfTuple? pform => [pform] + [:pf0FlattenSyntacticTuple p for p in pf0TupleParts pform] + diff --git a/src/interp/ptrees.boot.pamphlet b/src/interp/ptrees.boot.pamphlet deleted file mode 100644 index 414b09af..00000000 --- a/src/interp/ptrees.boot.pamphlet +++ /dev/null @@ -1,793 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp ptrees.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\begin{verbatim} -Abstract Syntax Trees - -This file provides functions to create and examine abstract -syntax trees. These are called pform, for short. -The definition of valid pforms see ABSTRACT BOOT. - -!! This file also contains constructors for concrete syntax, although -!! they should be somewhere else. - -THE PFORM DATA STRUCTURE - Leaves: [hd, tok, pos] - Trees: [hd, tree, tree, ...] - hd is either an id or (id . alist) - -\end{verbatim} -\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. - -@ -<<*>>= -<> - -import '"posit" -import '"serror" - -)package "BOOT" - ---% SPECIAL NODES -pfListOf x == pfTree('listOf,x) -pfListOf? x == pfAbSynOp?(x,'listOf) -pfAppend list == APPLY(function APPEND,list) - -pfNothing () == pfTree('nothing, []) -pfNothing? form == pfAbSynOp?(form, 'nothing) - --- SemiColon - -pfSemiColon(pfbody) == pfTree('SemiColon, [pfbody]) -pfSemiColon?(pf) == pfAbSynOp? (pf, 'SemiColon) -pfSemiColonBody pf == CADR pf -- was ==> - ---% LEAVES -pfId(expr) == pfLeaf('id, expr) -pfIdPos(expr,pos) == pfLeaf('id,expr,pos) -pfId? form == - pfAbSynOp?(form,'id) or pfAbSynOp?(form,'idsy) -pfSymbolVariable? form == pfAbSynOp?(form,'idsy) -pfIdSymbol form == tokPart form ---pfAmpersand(amptok,name) == name - -pfDocument strings == pfLeaf('Document, strings) -pfDocument? form == pfAbSynOp?(form, 'Document) -pfDocumentText form == tokPart form - -pfLiteral? form == - MEMQ(pfAbSynOp form,'(integer symbol expression - one zero char string float)) - -pfLiteralClass form == pfAbSynOp form -pfLiteralString form == tokPart form - -pfStringConstString form == tokPart form - -pfExpression(expr, :optpos) == - pfLeaf("expression", expr, IFCAR optpos) -pfExpression? form == pfAbSynOp?(form, 'expression) - -pfSymbol(expr, :optpos) == - pfLeaf("symbol", expr, IFCAR optpos) - -pfSymb(expr, :optpos) == - if pfLeaf? expr - then pfSymbol(tokPart expr,IFCAR optpos) - else pfExpression(pfSexpr expr,IFCAR optpos) - -pfSymbol? form == pfAbSynOp?(form, 'symbol) - -pfSymbolSymbol form == tokPart form - ---% TREES --- parser interface functions --- these are potential sources of trouble in macro expansion - --- the comment is attached to all signatutres -pfWDec(doc,name) == [pfWDeclare(i,doc) for i in pfParts name] - -pfTweakIf form== - a:=pfIfElse form - b:=if pfNothing? a then pfListOf [] else a - pfTree('WIf,[pfIfCond form,pfIfThen form,b]) - -pfInfApplication(op,left,right)== - pfCheckInfop left => - pfWrong(pfDocument ['"infop as argument to infop"],pfListOf []) - pfCheckInfop right => - pfWrong(pfDocument ['"infop as argument to infop"],pfListOf []) - EQ(pfIdSymbol op,"and")=> pfAnd (left,right) - EQ(pfIdSymbol op, "or")=> pfOr (left,right) - pfApplication(op,pfTuple pfListOf [left,right]) - -pfCheckInfop form== false - -pfAnd(pfleft, pfright) == pfTree('And, [pfleft, pfright]) -pfAnd?(pf) == pfAbSynOp? (pf, 'And) -pfAndLeft pf == CADR pf -- was ==> -pfAndRight pf == CADDR pf -- was ==> - -pfOr(pfleft, pfright) == pfTree('Or, [pfleft, pfright]) -pfOr?(pf) == pfAbSynOp? (pf, 'Or) -pfOrLeft pf == CADR pf -- was ==> -pfOrRight pf == CADDR pf -- was ==> - -pfNot(arg) == pfTree('Not, [arg]) -pfNot?(pf) == pfAbSynOp? (pf, 'Not) -pfNotArg pf == CADR pf -- was ==> - -pfEnSequence a== - if null a - then pfTuple pfListOf a - else if null cdr a - then car a - else pfSequence pfListOf a -pfFromDom(dom,expr)== - if pfApplication? expr - then pfApplication(pfFromdom(pfApplicationOp expr,dom), - pfApplicationArg expr) - else pfFromdom(expr,dom) - -pfReturnTyped(type,body)==pfTree('returntyped,[type,body]) - -pfLam(variable,body)==-- called from parser - rets:= if pfAbSynOp?(body,'returntyped) - then pfFirst body - else pfNothing () - bdy:= if pfAbSynOp?(body,'returntyped) then pfSecond body else body - pfLambda(variable,rets,bdy) - -pfTLam(variable,body)==-- called from parser - rets:= if pfAbSynOp?(body,'returntyped) - then pfFirst body - else pfNothing () - bdy:= if pfAbSynOp?(body,'returntyped) then pfSecond body else body - pfTLambda(variable,rets,bdy) - -pfIfThenOnly(pred,first)==pfIf(pred,first,pfNothing()) - -pfLp(iterators,body)== - pfLoop pfListOf [:iterators,pfDo body] -pfLoop1 body == pfLoop pfListOf [pfDo body] - - -pfExitNoCond value== pfExit(pfNothing(),value) - -pfReturnNoName(value)==pfReturn(value,pfNothing()) - -pfBrace(a,part)==pfApplication(pfIdPos( "{}",tokPosn a),part) - -pfBracket(a,part) == pfApplication(pfIdPos( "[]",tokPosn a),part) -pfBraceBar(a,part)==pfApplication(pfIdPos( "{||}",tokPosn a),part) - -pfBracketBar(a,part) == pfApplication(pfIdPos( "[||]",tokPosn a),part) -pfHide(a,part) == pfTree("Hide",[part]) -pfHide? x== pfAbSynOp?(x,"Hide") -pfHidePart x== CADR x -pfParen(a,part)==part - -pfPile(part)==part - -pfSpread(l,t)== [pfTyped(i,t) for i in l] - -pfTupleList form== pfParts pfTupleParts form - ---The rest have been generated from ABCUT INPUT --- 1/31/89 - - --- Add / Application / Assign / --- Coerceto / Collect / ComDefinition / DeclPart / --- Exit / Export / Free / --- Fromdom / Id / If / Inline / --- Iterate / Lambda / --- Break / Literal / Local / Loop / --- MLambda / Pretend / Restrict / Return / --- Sequence / Tagged / Tuple / Typing / --- Where / With - -pfExpr? pf == - pfAdd? pf or _ - pfApplication? pf or _ - pfAssign? pf or _ - pfCoerceto? pf or _ - pfCollect? pf or _ - pfComDefinition? pf or _ - pfDeclPart? pf or _ - pfExit? pf or _ - pfExport? pf or _ - pfFree? pf or _ - pfFromdom? pf or _ - pfId? pf or _ - pfIf? pf or _ - pfInline? pf or _ - pfIterate? pf or _ - pfLambda? pf or _ - pfBreak? pf or _ - pfLiteral? pf or _ - pfLocal? pf or _ - pfLoop? pf or _ - pfMLambda? pf or _ - pfPretend? pf or _ - pfRestrict? pf or _ - pfReturn? pf or _ - pfTagged? pf or _ - pfTuple? pf or _ - pfWhere? pf or _ - pfWith? pf - - -pfDeclPart? pf == - pfTyping? pf or _ - pfImport? pf or _ - pfDefinition? pf or _ - pfSequence? pf or _ - pfDWhere? pf or _ - pfMacro? pf - - --- Wrong := (Why: Document, Rubble: [Expr]) - -pfWrong(pfwhy, pfrubble) == pfTree('Wrong, [pfwhy, pfrubble]) -pfWrong?(pf) == pfAbSynOp? (pf, 'Wrong) -pfWrongWhy pf == CADR pf -- was ==> -pfWrongRubble pf == CADDR pf -- was ==> -pf0WrongRubble pf == pfParts pfWrongRubble pf - - --- Add := (Base: [Typed], Addin: Expr) - -pfAdd(pfbase, pfaddin,:addon) == - lhs := if addon - then first addon - else pfNothing() - pfTree('Add, [pfbase, pfaddin,lhs]) - -pfAdd?(pf) == pfAbSynOp? (pf, 'Add) -pfAddBase pf == CADR pf -- was ==> -pfAddAddin pf == CADDR pf -- was ==> -pfAddAddon pf == CADDDR pf -- was ==> -pf0AddBase pf == pfParts pfAddBase pf - - - --- DWhere := (Context: [DeclPart], Expr: [DeclPart]) - -pfDWhere(pfcontext, pfexpr) == pfTree('DWhere, [pfcontext, pfexpr]) -pfDWhere?(pf) == pfAbSynOp? (pf, 'DWhere) -pfDWhereContext pf == CADR pf -- was ==> -pfDWhereExpr pf == CADDR pf -- was ==> - - - --- With := (Base: [Typed], Within: [WithPart]) - -pfWith(pfbase, pfwithin,pfwithon) == - pfTree('With, [pfbase, pfwithin,pfwithon]) -pfWith?(pf) == pfAbSynOp? (pf, 'With) -pfWithBase pf == CADR pf -- was ==> -pfWithWithin pf == CADDR pf -- was ==> -pfWithWithon pf == CADDDR pf -- was ==> -pf0WithBase pf == pfParts pfWithBase pf -pf0WithWithin pf == pfParts pfWithWithin pf - - --- WIf := (Cond: Primary, Then: [WithPart], Else: [WithPart]) - -pfWIf(pfcond, pfthen, pfelse) == pfTree('WIf, [pfcond, pfthen, pfelse]) -pfWIf?(pf) == pfAbSynOp? (pf, 'WIf) -pfWIfCond pf == CADR pf -- was ==> -pfWIfThen pf == CADDR pf -- was ==> -pfWIfElse pf == CADDDR pf -- was ==> - --- WDeclare := (Signature: Typed, Doc: ? Document) - -pfWDeclare(pfsignature, pfdoc) == pfTree('WDeclare, [pfsignature, _ -pfdoc]) -pfWDeclare?(pf) == pfAbSynOp? (pf, 'WDeclare) -pfWDeclareSignature pf == CADR pf -- was ==> -pfWDeclareDoc pf == CADDR pf -- was ==> - - --- Attribute := (Expr: Primary) - -pfAttribute(pfexpr) == pfTree('Attribute, [pfexpr]) -pfAttribute?(pf) == pfAbSynOp? (pf, 'Attribute) -pfAttributeExpr pf == CADR pf -- was ==> - - --- Typed := (Id: Id, Type: ? Type) - -pfTyped(pfid, pftype) == pfTree('Typed, [pfid, pftype]) -pfTyped?(pf) == pfAbSynOp? (pf, 'Typed) -pfTypedId pf == CADR pf -- was ==> -pfTypedType pf == CADDR pf -- was ==> - - --- Application := (Op: Expr, Arg: Expr) - -pfApplication(pfop, pfarg) == - pfTree('Application, [pfop, pfarg]) - -pfApplication?(pf) == pfAbSynOp? (pf, 'Application) -pfApplicationOp pf == CADR pf -- was ==> -pfApplicationArg pf == CADDR pf -- was ==> - - --- Tuple := (Parts: [Expr]) - -pfTupleListOf(pfparts) == pfTuple pfListOf pfparts -pfTuple(pfparts) == pfTree('Tuple, [pfparts]) -pfTuple?(pf) == pfAbSynOp? (pf, 'Tuple) -pfTupleParts pf == CADR pf -- was ==> -pf0TupleParts pf == pfParts pfTupleParts pf - - --- Tagged := (Tag: Expr, Expr: Expr) - -pfTagged(pftag, pfexpr) == pfTree('Tagged, [pftag, pfexpr]) -pfTagged?(pf) == pfAbSynOp? (pf, 'Tagged) -pfTaggedTag pf == CADR pf -- was ==> -pfTaggedExpr pf == CADDR pf -- was ==> - - --- Pretend := (Expr: Expr, Type: Type) - -pfPretend(pfexpr, pftype) == pfTree('Pretend, [pfexpr, pftype]) -pfPretend?(pf) == pfAbSynOp? (pf, 'Pretend) -pfPretendExpr pf == CADR pf -- was ==> -pfPretendType pf == CADDR pf -- was ==> - - --- Restrict := (Expr: Expr, Type: Type) - -pfRestrict(pfexpr, pftype) == pfTree('Restrict, [pfexpr, pftype]) -pfRestrict?(pf) == pfAbSynOp? (pf, 'Restrict) -pfRestrictExpr pf == CADR pf -- was ==> -pfRestrictType pf == CADDR pf -- was ==> - -pfRetractTo(pfexpr, pftype) == pfTree('RetractTo, [pfexpr, pftype]) -pfRetractTo?(pf) == pfAbSynOp? (pf, 'RetractTo) -pfRetractToExpr pf == CADR pf -- was ==> -pfRetractToType pf == CADDR pf -- was ==> - - --- Coerceto := (Expr: Expr, Type: Type) - -pfCoerceto(pfexpr, pftype) == pfTree('Coerceto, [pfexpr, pftype]) -pfCoerceto?(pf) == pfAbSynOp? (pf, 'Coerceto) -pfCoercetoExpr pf == CADR pf -- was ==> -pfCoercetoType pf == CADDR pf -- was ==> - - --- Fromdom := (What: Id, Domain: Type) - -pfFromdom(pfwhat, pfdomain) == pfTree('Fromdom, [pfwhat, pfdomain]) -pfFromdom?(pf) == pfAbSynOp? (pf, 'Fromdom) -pfFromdomWhat pf == CADR pf -- was ==> -pfFromdomDomain pf == CADDR pf -- was ==> - - --- Lambda := (Args: [Typed], Rets: ? Type, Body: Expr) - -pfLambda(pfargs, pfrets, pfbody) == pfTree('Lambda, [pfargs, pfrets, _ -pfbody]) -pfLambda?(pf) == pfAbSynOp? (pf, 'Lambda) -pfLambdaArgs pf == CADR pf -- was ==> -pfLambdaRets pf == CADDR pf -- was ==> -pfLambdaBody pf == CADDDR pf -- was ==> -pf0LambdaArgs pf == pfParts pfLambdaArgs pf -pfFix pf== pfApplication(pfId "Y",pf) - - --- TLambda := (Args: [Typed], Rets: ? Type, Body: Expr) - -pfTLambda(pfargs, pfrets, pfbody) == pfTree('TLambda, [pfargs, pfrets, pfbody]) -pfTLambda?(pf) == pfAbSynOp? (pf, 'TLambda) -pfTLambdaArgs pf == CADR pf -- was ==> -pfTLambdaRets pf == CADDR pf -- was ==> -pfTLambdaBody pf == CADDDR pf -- was ==> -pf0TLambdaArgs pf == pfParts pfTLambdaArgs pf - - --- MLambda := (Args: [Id], Body: Expr) - -pfMLambda(pfargs, pfbody) == pfTree('MLambda, [pfargs, pfbody]) -pfMLambda?(pf) == pfAbSynOp? (pf, 'MLambda) -pfMLambdaArgs pf == CADR pf -- was ==> -pfMLambdaBody pf == CADDR pf -- was ==> -pf0MLambdaArgs pf == pfParts pfMLambdaArgs pf - - --- Where := (Context: [DeclPart], Expr: Expr) - -pfWhere(pfcontext, pfexpr) == pfTree('Where, [pfcontext, pfexpr]) -pfWhere?(pf) == pfAbSynOp? (pf, 'Where) -pfWhereContext pf == CADR pf -- was ==> -pfWhereExpr pf == CADDR pf -- was ==> -pf0WhereContext pf == pfParts pfWhereContext pf - - --- If := (Cond: Expr, Then: Expr, Else: ? Expr) - -pfIf(pfcond, pfthen, pfelse) == pfTree('If, [pfcond, pfthen, pfelse]) -pfIf?(pf) == pfAbSynOp? (pf, 'If) -pfIfCond pf == CADR pf -- was ==> -pfIfThen pf == CADDR pf -- was ==> -pfIfElse pf == CADDDR pf -- was ==> - - --- Sequence := (Args: [Expr]) - -pfSequence(pfargs) == pfTree('Sequence, [pfargs]) -pfSequence?(pf) == pfAbSynOp? (pf, 'Sequence) -pfSequenceArgs pf == CADR pf -- was ==> -pf0SequenceArgs pf == pfParts pfSequenceArgs pf - - --- Novalue := (Expr: Expr) - -pfNovalue(pfexpr) == pfTree('Novalue, [pfexpr]) -pfNovalue?(pf) == pfAbSynOp? (pf, 'Novalue) -pfNovalueExpr pf == CADR pf -- was ==> - - --- Loop := (Iterators: [Iterator]) - -pfLoop(pfiterators) == pfTree('Loop, [pfiterators]) -pfLoop?(pf) == pfAbSynOp? (pf, 'Loop) -pfLoopIterators pf == CADR pf -- was ==> -pf0LoopIterators pf == pfParts pfLoopIterators pf - - --- Collect := (Body: Expr, Iterators: [Iterator]) - -pfCollect(pfbody, pfiterators) == pfTree('Collect, [pfbody, _ -pfiterators]) -pfCollect?(pf) == pfAbSynOp? (pf, 'Collect) -pfCollectBody pf == CADR pf -- was ==> -pfCollectIterators pf == CADDR pf -- was ==> -pf0CollectIterators pf == pfParts pfCollectIterators pf - - --- Forin := (Lhs: [AssLhs], Whole: Expr) - -pfForin(pflhs, pfwhole) == pfTree('Forin, [pflhs, pfwhole]) -pfForin?(pf) == pfAbSynOp? (pf, 'Forin) -pfForinLhs pf == CADR pf -- was ==> -pfForinWhole pf == CADDR pf -- was ==> -pf0ForinLhs pf == pfParts pfForinLhs pf - - --- While := (Cond: Expr) - -pfWhile(pfcond) == pfTree('While, [pfcond]) -pfWhile?(pf) == pfAbSynOp? (pf, 'While) -pfWhileCond pf == CADR pf -- was ==> - - --- Until := (Cond: Expr) - ---pfUntil(pfcond) == pfTree('Until, [pfcond]) ---pfUntil?(pf) == pfAbSynOp? (pf, 'Until) ---pfUntilCond pf == CADR pf -- was ==> - - --- Suchthat := (Cond: Expr) - -pfSuchthat(pfcond) == pfTree('Suchthat, [pfcond]) -pfSuchthat?(pf) == pfAbSynOp? (pf, 'Suchthat) -pfSuchthatCond pf == CADR pf -- was ==> - - --- Do := (Body: Expr) - -pfDo(pfbody) == pfTree('Do, [pfbody]) -pfDo?(pf) == pfAbSynOp? (pf, 'Do) -pfDoBody pf == CADR pf -- was ==> - - --- Iterate := (From: ? Id) - -pfIterate(pffrom) == pfTree('Iterate, [pffrom]) -pfIterate?(pf) == pfAbSynOp? (pf, 'Iterate) -pfIterateFrom pf == CADR pf -- was ==> - - --- Break := (From: ? Id) - -pfBreak(pffrom) == pfTree('Break, [pffrom]) -pfBreak?(pf) == pfAbSynOp? (pf, 'Break) -pfBreakFrom pf == CADR pf -- was ==> - - --- Return := (Expr: ? Expr, From: ? Id) - -pfReturn(pfexpr, pffrom) == pfTree('Return, [pfexpr, pffrom]) -pfReturn?(pf) == pfAbSynOp? (pf, 'Return) -pfReturnExpr pf == CADR pf -- was ==> -pfReturnFrom pf == CADDR pf -- was ==> - - --- Exit := (Cond: ? Expr, Expr: ? Expr) - -pfExit(pfcond, pfexpr) == pfTree('Exit, [pfcond, pfexpr]) -pfExit?(pf) == pfAbSynOp? (pf, 'Exit) -pfExitCond pf == CADR pf -- was ==> -pfExitExpr pf == CADDR pf -- was ==> - - --- Macro := (Lhs: Id, Rhs: ExprorNot) - -pfMacro(pflhs, pfrhs) == pfTree('Macro, [pflhs, pfrhs]) -pfMacro?(pf) == pfAbSynOp? (pf, 'Macro) -pfMacroLhs pf == CADR pf -- was ==> -pfMacroRhs pf == CADDR pf -- was ==> - - --- Definition := (LhsItems: [Typed], Rhs: Expr) - -pfDefinition(pflhsitems, pfrhs) == pfTree('Definition, [pflhsitems, pfrhs]) -pfDefinition?(pf) == pfAbSynOp? (pf, 'Definition) -pfDefinitionLhsItems pf == CADR pf -- was ==> -pfDefinitionRhs pf == CADDR pf -- was ==> -pf0DefinitionLhsItems pf == pfParts pfDefinitionLhsItems pf - -pfRule(pflhsitems, pfrhs) == pfTree('Rule, [pflhsitems, _ -pfrhs]) -pfRule?(pf) == pfAbSynOp? (pf, 'Rule) -pfRuleLhsItems pf == CADR pf -- was ==> -pfRuleRhs pf == CADDR pf -- was ==> - --- ComDefinition := (Doc:Document,Def:Definition) - -pfComDefinition(pfdoc, pfdef) == pfTree('ComDefinition, [pfdoc, pfdef] ) -pfComDefinition?(pf) == pfAbSynOp? (pf, 'ComDefinition) -pfComDefinitionDoc pf == CADR pf -- was ==> -pfComDefinitionDef pf == CADDR pf -- was ==> - - --- DefinitionSequence := (Args: [DeclPart]) - -pfDefinitionSequenceArgs pf == CADR pf -- was ==> - --- Export := (Def: Definition) - -pfExportDef pf == CADR pf -- was ==> - --- Assign := (LhsItems: [AssLhs], Rhs: Expr) - -pfAssign(pflhsitems, pfrhs) == pfTree('Assign, [pflhsitems, pfrhs]) -pfAssign?(pf) == pfAbSynOp? (pf, 'Assign) -pfAssignLhsItems pf == CADR pf -- was ==> -pfAssignRhs pf == CADDR pf -- was ==> -pf0AssignLhsItems pf == pfParts pfAssignLhsItems pf - - --- Typing := (Items: [Typed]) - -pfTyping(pfitems) == pfTree('Typing, [pfitems]) -pfTyping?(pf) == pfAbSynOp? (pf, 'Typing) -pfTypingItems pf == CADR pf -- was ==> -pf0TypingItems pf == pfParts pfTypingItems pf - - --- Export := (Items: [Typed]) - -pfExport(pfitems) == pfTree('Export, [pfitems]) -pfExport?(pf) == pfAbSynOp? (pf, 'Export) -pfExportItems pf == CADR pf -- was ==> -pf0ExportItems pf == pfParts pfExportItems pf - - --- Local := (Items: [Typed]) - -pfLocal(pfitems) == pfTree('Local, [pfitems]) -pfLocal?(pf) == pfAbSynOp? (pf, 'Local) -pfLocalItems pf == CADR pf -- was ==> -pf0LocalItems pf == pfParts pfLocalItems pf - --- Free := (Items: [Typed]) - -pfFree(pfitems) == pfTree('Free, [pfitems]) -pfFree?(pf) == pfAbSynOp? (pf, 'Free) -pfFreeItems pf == CADR pf -- was ==> -pf0FreeItems pf == pfParts pfFreeItems pf - - --- Import := (Items: [QualType]) - -pfImport(pfitems) == pfTree('Import, [pfitems]) -pfImport?(pf) == pfAbSynOp? (pf, 'Import) -pfImportItems pf == CADR pf -- was ==> -pf0ImportItems pf == pfParts pfImportItems pf - - --- Inline := (Items: [QualType]) - -pfInline(pfitems) == pfTree('Inline, [pfitems]) -pfInline?(pf) == pfAbSynOp? (pf, 'Inline) -pfInlineItems pf == CADR pf -- was ==> - --- QualType := (Type: Type, Qual: ? Type) - -pfQualType(pftype, pfqual) == pfTree('QualType, [pftype, pfqual]) -pfQualType?(pf) == pfAbSynOp? (pf, 'QualType) -pfQualTypeType pf == CADR pf -- was ==> -pfQualTypeQual pf == CADDR pf -- was ==> - -pfSuch(x,y)== pfInfApplication(pfId "|",x,y) - -pfTaggedToTyped x== - rt:=if pfTagged? x then pfTaggedExpr x else pfNothing() - form:= if pfTagged? x then pfTaggedTag x else x - not pfId? form => - a:=pfId GENSYM() - pfTyped(pfSuch(a, - pfInfApplication (pfId "=", a,form)),rt) - pfTyped(form,rt) - -pfTaggedToTyped1 x== - pfCollect1? x => pfCollectVariable1 x - pfDefinition? x => pfTyped(x,pfNothing()) - pfTaggedToTyped x - -pfCollectVariable1 x== - a := pfApplicationArg x - var:=first pf0TupleParts a - id:=pfTaggedToTyped var - pfTyped(pfSuch(pfTypedId id,CADR pf0TupleParts a), - pfTypedType id) - -pfPushBody(t,args,body)== - if null args - then body - else if null rest args - then pfLambda(first args,t,body) - else - pfLambda(first args,pfNothing(), - pfPushBody(t,rest args,body)) - -pfCheckItOut x == - rt:=if pfTagged? x then pfTaggedExpr x else pfNothing() - form:= if pfTagged? x then pfTaggedTag x else x - pfId? form => [pfListOf [pfTyped(form,rt)],nil,rt] - pfCollect1? form => - [pfListOf [pfCollectVariable1 form],nil,rt] - pfTuple? form => - [pfListOf [pfTaggedToTyped i for i in pf0TupleParts form],nil,rt] - pfDefinition? form => - [pfListOf [pfTyped(form,pfNothing())],nil,rt] - pfApplication? form => - ls:=pfFlattenApp form - op:= pfTaggedToTyped1 first ls - args:=[pfTransformArg i for i in rest ls] - [pfListOf [op],args,rt] - npTrapForm form - -pfCollect1? x== - pfApplication? x => - a:=pfApplicationOp x - pfId? a => pfIdSymbol a = "|" - false - false - -pfTransformArg args== - argl:= if pfTuple? args then pf0TupleParts args else [args] - pfListOf [pfTaggedToTyped1 i for i in argl] - - -pfCheckMacroOut form == - pfId? form => [form,nil] - pfApplication? form => - ls:=pfFlattenApp form - op:= pfCheckId first ls - args:=[pfCheckArg i for i in rest ls] - [op,args] - npTrapForm form - -pfCheckArg args== - argl:= if pfTuple? args then pf0TupleParts args else [args] - pfListOf [pfCheckId i for i in argl] - -pfCheckId form== if not pfId? form then npTrapForm(form) else form - -pfPushMacroBody(args,body)== - null args => body - pfMLambda(first args,pfPushMacroBody(rest args,body)) - -pfFlattenApp x== - pfApplication? x=> - pfCollect1? x =>[ x ] - append (pfFlattenApp pfApplicationOp x, - pfFlattenApp pfApplicationArg x) - [x] - - ---% Utility operations on Abstract Syntax Trees - --- An S-expression which people can read. -pfSexpr pform == - strip pform where - strip pform == - pfId? pform => pfIdSymbol pform - pfLiteral? pform => pfLiteralString pform - pfLeaf? pform => tokPart pform - - pfApplication? pform => - args := - a := pfApplicationArg pform - if pfTuple? a then pf0TupleParts a else [a] - [strip p for p in cons(pfApplicationOp pform, args)] - - cons(pfAbSynOp pform, [strip p for p in pfParts pform]) - -pfCopyWithPos( pform , pos ) == - pfLeaf? pform => pfLeaf( pfAbSynOp pform , tokPart pform , pos ) - pfTree( pfAbSynOp pform , [ pfCopyWithPos( p , pos ) for p in pfParts pform ] ) - -pfMapParts(f, pform) == - pfLeaf? pform => pform - parts0 := pfParts pform - parts1 := [FUNCALL(f, p) for p in parts0] - -- Return the original if no changes. - same := true - for p0 in parts0 for p1 in parts1 while same repeat same := EQ(p0,p1) - same => pform - pfTree(pfAbSynOp pform, parts1) - - -pf0ApplicationArgs pform == - arg := pfApplicationArg pform - pf0FlattenSyntacticTuple arg - -pf0FlattenSyntacticTuple pform == - not pfTuple? pform => [pform] - [:pf0FlattenSyntacticTuple p for p in pf0TupleParts pform] - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/redefs.boot.pamphlet b/src/interp/redefs.boot.pamphlet deleted file mode 100644 index 519c3fbb..00000000 --- a/src/interp/redefs.boot.pamphlet +++ /dev/null @@ -1,92 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp redefs.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\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" - -BLANKS n== MAKE_-FULL_-CVEC (n) - -object2String x== - STRINGP x=>x - IDENTP x=> PNAME x - STRINGIMAGE x - -sayMSG x== shoeConsole x -sayBrightly x== - brightPrint x - TERPRI() -;;char x==CHAR(PNAME x,0) -pathname x==CONCAT(PNAME(x.0),'".",PNAME(x.1)) -CVECP x== STRINGP x -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] - ---$FILESIZE x== --- a:=OPEN MAKE_-INPUT_-FILENAME x --- b:=FILE_-LENGTH a --- CLOSE a --- b -SPADCATCH(x,y)==CATCH(x,y) -SPADTHROW(x,y)==THROW(x,y) -listSort(f,l)== SORT(l,f) -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/rulesets.boot b/src/interp/rulesets.boot new file mode 100644 index 00000000..0e786f7f --- /dev/null +++ b/src/interp/rulesets.boot @@ -0,0 +1,308 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- 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. + + +import '"vmlisp" +)package "BOOT" + +--% Mode and Type Resolution Rule Data and Ruleset Creation + +--% resolveTT Rules + +-- These rules are applied only once at the outermost position of a term +-- some things can't be done by term rewriting conveniently (e.g. set +-- difference), so a form is created which is interpreted by +-- resolveTTRed later. The meanings of these forms are: +-- Incl(x,y): y if x is a member of y, failed otherwise +-- SetEqual(x,y): x if y is a permutation of x, failed otherwise +-- SetComp(x,y): x-y, if y is a subset of x, failed otherwise +-- SetInter(x,y): intersection of x and y, if nonempty, failed otherwise +-- SetDiff(x,y): x-y, if x and y have a nonempty intersection, failed ... + +-- These first rules will be expanded for each of MP, DMP and NDMP + +$mpolyTTRules == '( _ + ((Resolve (RN) (mpoly1 x t1)) . (mpoly1 x (Resolve (RN) t1))) _ + ((Resolve (UP x t1) (mpoly1 y t2)) . _ + (Resolve t1 (mpoly1 (Incl x y) t2))) _ + ((Resolve (mpoly1 x t1) (G t2)) . _ + (mpoly1 x (G (VarEqual t1 t2)))) _ + ((Resolve (VARIABLE x) (mpoly1 y t2)) . _ + (mpoly1 (Incl x y) t2)) _ + ((Resolve (mpoly1 x t1) (mpoly1 y t2)) . _ + (mpoly1 (SetEqual x y) (Resolve t1 t2))) _ + ((Resolve (mpoly1 x t1) (mpoly1 y t2)) . _ + (mpoly1 x (Resolve t1 (mpoly1 (SetComp y x) t2)))) _ + ((Resolve (mpoly1 x t1) (mpoly1 y t2)) . _ + (mpoly1 y (Resolve (mpoly1 (SetComp x y) t1) t2))) _ + ((Resolve (mpoly1 x t1) (mpoly1 y t2)) . _ + (mpoly1 (SetInter x y) (Resolve _ + (mpoly1 (SetDiff x y) t1) (mpoly1 (SetDiff y x) t2)))) _ + ) + +-- These are the general rules, excluding those above. + +$generalTTRules == '( _ + ((Resolve (L (L t1)) (M t2)) . (M (Resolve t1 t2))) _ + ((Resolve (EQ t1) (B)) . (B)) _ + ((Resolve (SY) t1) . (Resolve (P (I)) t1)) _ + ((Resolve (M t1) (SM x t2)) . (M (Resolve t1 t2))) _ + ((Resolve (M t1) (RM x y t2)) . (M (Resolve t1 t2))) _ + ((Resolve (SM x t1) (RM y y t2)) . _ + (SM (VarEqual x y) (Resolve t1 t2))) _ + ((Resolve (V t1) (L t2)) . (V (Resolve t1 t2))) _ + ((Resolve (FF t1) (FR t2)) . (FR (Resolve t1 t2))) _ + ((Resolve (F) (RN)) . (F) ) _ + _ + ((Resolve (OV x) (OV y)) . (OV (SetUnion x y))) _ + ((Resolve (P t1) (UP y t2)) . (Resolve (P t1) t2)) _ + _ + ((Resolve (UP y t1) (G t2)) . (UP y (G (VarEqual t1 t2)))) _ + ((Resolve (P t1) (P t2)) . (P (Resolve t1 t2))) _ + ((Resolve (G t1) (G t2)) . (G (Resolve t1 t2))) _ + ((Resolve (G t1) (P t2)) . (P (G (VarEqual t1 t2)))) _ + _ + ((Resolve (AF t1) (EF t2)) . (EF (Resolve t1 t2))) _ + ((Resolve (AF t1) (LF t2)) . (LF (Resolve t1 t2))) _ + ((Resolve (AF t1) (FE t2)) . (FE (Resolve t1 t2))) _ + ((Resolve (EF t1) (LF t2)) . (LF (Resolve t1 t2))) _ + ((Resolve (EF t1) (FE t2)) . (FE (Resolve t1 t2))) _ + ((Resolve (LF t1) (FE t2)) . (FE (Resolve t1 t2))) _ + _ + ((Resolve (RN) (P t1)) . (P (Resolve (RN) t1))) _ + ((Resolve (RN) (UP x t1)) . (UP x (Resolve (RN) t1))) _ + ((Resolve (RN) (UPS x t1)) . (UPS x (Resolve (RN) t1))) _ + ((Resolve (RN) (CFPS x t1)) . (CFPS x (Resolve (RN) t1))) _ + _ + ((Resolve (RR) (EF t1)) . (EF (Resolve (RR) t1))) _ + ((Resolve (P t1) (AF t2)) . (AF (Resolve t1 t2 ))) _ + ((Resolve (P t1) (EF t2)) . (EF (Resolve t1 t2 ))) _ + ((Resolve (P t1) (LF t2)) . (LF (Resolve t1 t2 ))) _ + _ + ((Resolve (MP x t1) (DMP y t2)) . _ + (MP (SetEqual x y) (Resolve t1 t2))) _ + ((Resolve (MP x t1) (DMP y t2)) . _ + (MP x (Resolve t1 (DMP (SetComp y x) t2)))) _ + ((Resolve (MP x t1) (DMP y t2)) . _ + (MP y (Resolve (MP (SetComp x y) t1) t2))) _ + ((Resolve (MP x t1) (DMP y t2)) . _ + (MP (SetInter x y) (Resolve _ + (MP (SetDiff x y) t1) (DMP (SetDiff y x) t2)))) _ + _ + ((Resolve (MP x t1) (NDMP y t2)) . _ + (MP (SetEqual x y) (Resolve t1 t2))) _ + ((Resolve (MP x t1) (NDMP y t2)) . _ + (MP x (Resolve t1 (NDMP (SetComp y x) t2)))) _ + ((Resolve (MP x t1) (NDMP y t2)) . _ + (MP y (Resolve (MP (SetComp x y) t1) t2))) _ + ((Resolve (MP x t1) (NDMP y t2)) . _ + (MP (SetInter x y) (Resolve _ + (MP (SetDiff x y) t1) (NDMP (SetDiff y x) t2)))) _ + _ + ((Resolve (DMP x t1) (NDMP y t2)) . _ + (DMP (SetEqual x y) (Resolve t1 t2))) _ + ((Resolve (DMP x t1) (NDMP y t2)) . _ + (DMP x (Resolve t1 (NDMP (SetComp y x) t2)))) _ + ((Resolve (DMP x t1) (NDMP y t2)) . _ + (DMP y (Resolve (DMP (SetComp x y) t1) t2))) _ + ((Resolve (DMP x t1) (NDMP y t2)) . _ + (DMP (SetInter x y) (Resolve _ + (DMP (SetDiff x y) t1) (NDMP (SetDiff y x) t2)))) _ + ) + +-- The following creates the ruleset + +createResolveTTRules() == + -- expand multivariate polynomial rules + mps := '(MP DMP NDMP) + mpRules := "append"/[SUBST(mp,'mpoly1,$mpolyTTRules) for mp in mps] + $Res := CONS('(t1 t2 x y), + EQSUBSTLIST($nameList,$abList,append($generalTTRules,mpRules))) + true + +--% resolveTM Rules + +-- Same rules as for resolveTT, with two exceptions: +-- Diff(x,y): removes y from x, if possible, failed otherwise +-- SetIncl(x,y): y if x is a subset of y, failed otherwise + +-- These first rules will be expanded for each of MP, DMP and NDMP + +$mpolyTMRules == '( _ + ((Resolve (mpoly1 x t1) (P t2)) . (Resolve t1 (P t2))) _ + ((Resolve (mpoly1 (x) t1) (UP x t2)) . (UP x (Resolve t1 t2))) _ + ((Resolve (mpoly1 x t1) (UP y t2)) . _ + (UP y (Resolve (mpoly1 (Diff x y) t1) t2))) _ + ((Resolve (UP x t1) (mpoly1 y t2)) . _ + (Resolve t1 (mpoly1 (Incl x y) t2))) _ + ((Resolve (VARIABLE x) (mpoly1 y t2)) . _ + (mpoly1 (Incl x y) (Resolve (I) t2))) _ + ((Resolve (mpoly1 x t1) (mpoly2 y t2)) . _ + (Resolve t1 (mpoly2 (SetIncl x y) t2))) _ + ((Resolve (mpoly1 x t1) (mpoly2 y t2)) . _ + (mpoly2 y (Resolve (mpoly1 (SetComp x y) t1) t2))) _ + ((Resolve (mpoly1 x t1) (mpoly2 y t2)) . _ + (Resolve (mpoly1 (SetDiff x y) t1) (mpoly2 y t2))) _ + ) + +-- These are the general rules, excluding those above. + +$generalTMRules == '( _ + ((Resolve (VARIABLE x) (P t1)) . (P (Resolve (I) t1))) _ + ((Resolve (VARIABLE x) (UP y t1)) . _ + (UP (VarEqual x y) (Resolve (I) t1))) _ + ((Resolve (VARIABLE x) (UPS y t1)) . _ + (UPS (VarEqual x y) (Resolve (I) t1))) _ + ((Resolve (VARIABLE x) (CFPS y t1)) . _ + (CFPS (VarEqual x y) (Resolve (RN) t1))) _ + ((Resolve (VARIABLE x) (ELFPS y t1)) . _ + (ELFPS (VarEqual x y) (Resolve (RN) t1))) _ + ((Resolve (VARIABLE x) (EF t1)) . (EF t1)) _ + ((Resolve (L (L (SY))) (M _*_*)) . (M (P (I)))) _ + ((Resolve (L (L (SY))) (SM x _*_*)) . (SM x (P (I)))) _ + ((Resolve (L (L t1)) (M t2)) . (M (Resolve t1 t2))) _ + ((Resolve (L (L t1)) (SM x t2)) . (SM x (Resolve t1 t2))) _ + ((Resolve (L (L t1)) (RM x y t2)) . (RM x y (Resolve t1 t2))) _ + ((Resolve (SY) t1) . (Resolve (P (I)) t1)) _ + ((Resolve (VARIABLE x) t1) . (Resolve (P (I)) t1)) _ + ((Resolve (SM x t1) (M t2)) . (M (Resolve t1 t2))) _ + ((Resolve (RM x y t1) (M t2)) . (M (Resolve t1 t2))) _ + _ + ((Resolve (M t1) (L _*_*)) . (L (L t1))) _ + ((Resolve (SM x t1) (L _*_*)) . (L (L t1))) _ + ((Resolve (RM x y t1) (L _*_*)) . (L (L t1))) _ + ((Resolve (M t1) (L t2)) . (L (Resolve (L t1) t2))) _ + ((Resolve (SM x t1) (L t2)) . (L (Resolve (L t1) t2))) _ + ((Resolve (RM x y t1) (L t2)) . (L (Resolve (L t1) t2))) _ + _ + ((Resolve (M t1) (V _*_*)) . (V (V t1))) _ + ((Resolve (SM x t1) (V _*_*)) . (V (V t1))) _ + ((Resolve (RM x y t1) (V _*_*)) . (V (V t1))) _ + ((Resolve (M t1) (V t2)) . (V (Resolve (V t1) t2))) _ + ((Resolve (SM x t1) (V t2)) . (V (Resolve (V t1) t2))) _ + ((Resolve (RM x y t1) (V t2)) . (V (Resolve (V t1) t2))) _ + _ + ((Resolve (L t1) (V t2)) . (V (Resolve t1 t2))) _ + ((Resolve (V t1) (L t2)) . (L (Resolve t1 t2))) _ + ((Resolve (FF t1) (FR t2)) . (FR (Resolve t1 t2))) _ + ((Resolve (UP x t1) (P t2)) . (Resolve t1 (P t2))) _ + ) + +-- Private abbreviation table for resolve rules +$resolveAbbreviations == '( _ + (P . Polynomial) _ + (G . Gaussian) _ + (L . List) _ + (M . Matrix) _ + (EQ . Equation) _ + (B . Boolean) _ + (SY . Symbol) _ + (I . Integer) _ + (SM . SquareMatrix) _ + (RM . RectangularMatrix) _ + (V . Vector) _ + (FF . FactoredForm) _ + (FR . FactoredRing) _ + (RN . RationalNumber) _ + (F . Float) _ + (OV . OrderedVariableList) _ + (UP . UnivariatePoly) _ + (DMP . DistributedMultivariatePolynomial) _ + (MP . MultivariatePolynomial) _ + (HDMP . HomogeneousDistributedMultivariatePolynomial) _ + (QF . QuotientField) _ + (RF . RationalFunction) _ + (RE . RadicalExtension) _ + (RR . RationalRadicals) _ + (UPS . UnivariatePowerSeries) _ + (CFPS . ContinuedFractionPowerSeries) _ + (ELFPS . EllipticFunctionPowerSeries) _ + (EF . ElementaryFunction) _ + (VARIABLE . Variable) _ + ) + +$newResolveAbbreviations == '( _ + (P . Polynomial) _ + (G . Complex) _ + (L . List) _ + (M . Matrix) _ + (EQ . Equation) _ + (B . Boolean) _ + (SY . Symbol) _ + (I . Integer) _ + (SM . SquareMatrix) _ + (RM . RectangularMatrix) _ + (V . Vector) _ + (FF . Factored) _ + (FR . Factored) _ + (F . Float) _ + (OV . OrderedVariableList) _ + (UP . UnivariatePolynomial) _ + (DMP . DistributedMultivariatePolynomial) _ + (MP . MultivariatePolynomial) _ + (HDMP . HomogeneousDistributedMultivariatePolynomial) _ + (QF . Fraction) _ + (UPS . UnivariatePowerSeries) _ + (VARIABLE . Variable) _ + ) + +-- The following creates the ruleset + +createResolveTMRules() == + -- expand multivariate polynomial rules + mps := '(MP DMP NDMP) + mpRules0 := "append"/[SUBST(mp,'mpoly1,$mpolyTMRules) for mp in mps] + mpRules := "append"/[SUBST(mp,'mpoly2,mpRules0) for mp in mps] + $ResMode := CONS('(t1 t2 x y), + EQSUBSTLIST($nameList,$abList,append(mpRules,$generalTMRules))) + true + +createTypeEquivRules() == + -- used by eqType, for example + $TypeEQ := CONS('(t1), EQSUBSTLIST($nameList,$abList,'( + ((QF (P t1)) . (RF t1)) + ((QF (I)) . (RN)) + ((RE (RN)) . (RR)) ))) + $TypeEqui := CONS(CAR $TypeEQ, [[b,:a] for [a,:b] in CDR $TypeEQ]) + true + +initializeRuleSets() == + $abList: local := + ASSOCLEFT $newResolveAbbreviations + $nameList: local := + ASSOCRIGHT $newResolveAbbreviations + createResolveTTRules() + createResolveTMRules() + createTypeEquivRules() + $ruleSetsInitialized := true + true diff --git a/src/interp/rulesets.boot.pamphlet b/src/interp/rulesets.boot.pamphlet deleted file mode 100644 index 9c1ccd82..00000000 --- a/src/interp/rulesets.boot.pamphlet +++ /dev/null @@ -1,328 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp rulesets.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\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. - -@ -<<*>>= -<> - -import '"vmlisp" -)package "BOOT" - ---% Mode and Type Resolution Rule Data and Ruleset Creation - ---% resolveTT Rules - --- These rules are applied only once at the outermost position of a term --- some things can't be done by term rewriting conveniently (e.g. set --- difference), so a form is created which is interpreted by --- resolveTTRed later. The meanings of these forms are: --- Incl(x,y): y if x is a member of y, failed otherwise --- SetEqual(x,y): x if y is a permutation of x, failed otherwise --- SetComp(x,y): x-y, if y is a subset of x, failed otherwise --- SetInter(x,y): intersection of x and y, if nonempty, failed otherwise --- SetDiff(x,y): x-y, if x and y have a nonempty intersection, failed ... - --- These first rules will be expanded for each of MP, DMP and NDMP - -$mpolyTTRules == '( _ - ((Resolve (RN) (mpoly1 x t1)) . (mpoly1 x (Resolve (RN) t1))) _ - ((Resolve (UP x t1) (mpoly1 y t2)) . _ - (Resolve t1 (mpoly1 (Incl x y) t2))) _ - ((Resolve (mpoly1 x t1) (G t2)) . _ - (mpoly1 x (G (VarEqual t1 t2)))) _ - ((Resolve (VARIABLE x) (mpoly1 y t2)) . _ - (mpoly1 (Incl x y) t2)) _ - ((Resolve (mpoly1 x t1) (mpoly1 y t2)) . _ - (mpoly1 (SetEqual x y) (Resolve t1 t2))) _ - ((Resolve (mpoly1 x t1) (mpoly1 y t2)) . _ - (mpoly1 x (Resolve t1 (mpoly1 (SetComp y x) t2)))) _ - ((Resolve (mpoly1 x t1) (mpoly1 y t2)) . _ - (mpoly1 y (Resolve (mpoly1 (SetComp x y) t1) t2))) _ - ((Resolve (mpoly1 x t1) (mpoly1 y t2)) . _ - (mpoly1 (SetInter x y) (Resolve _ - (mpoly1 (SetDiff x y) t1) (mpoly1 (SetDiff y x) t2)))) _ - ) - --- These are the general rules, excluding those above. - -$generalTTRules == '( _ - ((Resolve (L (L t1)) (M t2)) . (M (Resolve t1 t2))) _ - ((Resolve (EQ t1) (B)) . (B)) _ - ((Resolve (SY) t1) . (Resolve (P (I)) t1)) _ - ((Resolve (M t1) (SM x t2)) . (M (Resolve t1 t2))) _ - ((Resolve (M t1) (RM x y t2)) . (M (Resolve t1 t2))) _ - ((Resolve (SM x t1) (RM y y t2)) . _ - (SM (VarEqual x y) (Resolve t1 t2))) _ - ((Resolve (V t1) (L t2)) . (V (Resolve t1 t2))) _ - ((Resolve (FF t1) (FR t2)) . (FR (Resolve t1 t2))) _ - ((Resolve (F) (RN)) . (F) ) _ - _ - ((Resolve (OV x) (OV y)) . (OV (SetUnion x y))) _ - ((Resolve (P t1) (UP y t2)) . (Resolve (P t1) t2)) _ - _ - ((Resolve (UP y t1) (G t2)) . (UP y (G (VarEqual t1 t2)))) _ - ((Resolve (P t1) (P t2)) . (P (Resolve t1 t2))) _ - ((Resolve (G t1) (G t2)) . (G (Resolve t1 t2))) _ - ((Resolve (G t1) (P t2)) . (P (G (VarEqual t1 t2)))) _ - _ - ((Resolve (AF t1) (EF t2)) . (EF (Resolve t1 t2))) _ - ((Resolve (AF t1) (LF t2)) . (LF (Resolve t1 t2))) _ - ((Resolve (AF t1) (FE t2)) . (FE (Resolve t1 t2))) _ - ((Resolve (EF t1) (LF t2)) . (LF (Resolve t1 t2))) _ - ((Resolve (EF t1) (FE t2)) . (FE (Resolve t1 t2))) _ - ((Resolve (LF t1) (FE t2)) . (FE (Resolve t1 t2))) _ - _ - ((Resolve (RN) (P t1)) . (P (Resolve (RN) t1))) _ - ((Resolve (RN) (UP x t1)) . (UP x (Resolve (RN) t1))) _ - ((Resolve (RN) (UPS x t1)) . (UPS x (Resolve (RN) t1))) _ - ((Resolve (RN) (CFPS x t1)) . (CFPS x (Resolve (RN) t1))) _ - _ - ((Resolve (RR) (EF t1)) . (EF (Resolve (RR) t1))) _ - ((Resolve (P t1) (AF t2)) . (AF (Resolve t1 t2 ))) _ - ((Resolve (P t1) (EF t2)) . (EF (Resolve t1 t2 ))) _ - ((Resolve (P t1) (LF t2)) . (LF (Resolve t1 t2 ))) _ - _ - ((Resolve (MP x t1) (DMP y t2)) . _ - (MP (SetEqual x y) (Resolve t1 t2))) _ - ((Resolve (MP x t1) (DMP y t2)) . _ - (MP x (Resolve t1 (DMP (SetComp y x) t2)))) _ - ((Resolve (MP x t1) (DMP y t2)) . _ - (MP y (Resolve (MP (SetComp x y) t1) t2))) _ - ((Resolve (MP x t1) (DMP y t2)) . _ - (MP (SetInter x y) (Resolve _ - (MP (SetDiff x y) t1) (DMP (SetDiff y x) t2)))) _ - _ - ((Resolve (MP x t1) (NDMP y t2)) . _ - (MP (SetEqual x y) (Resolve t1 t2))) _ - ((Resolve (MP x t1) (NDMP y t2)) . _ - (MP x (Resolve t1 (NDMP (SetComp y x) t2)))) _ - ((Resolve (MP x t1) (NDMP y t2)) . _ - (MP y (Resolve (MP (SetComp x y) t1) t2))) _ - ((Resolve (MP x t1) (NDMP y t2)) . _ - (MP (SetInter x y) (Resolve _ - (MP (SetDiff x y) t1) (NDMP (SetDiff y x) t2)))) _ - _ - ((Resolve (DMP x t1) (NDMP y t2)) . _ - (DMP (SetEqual x y) (Resolve t1 t2))) _ - ((Resolve (DMP x t1) (NDMP y t2)) . _ - (DMP x (Resolve t1 (NDMP (SetComp y x) t2)))) _ - ((Resolve (DMP x t1) (NDMP y t2)) . _ - (DMP y (Resolve (DMP (SetComp x y) t1) t2))) _ - ((Resolve (DMP x t1) (NDMP y t2)) . _ - (DMP (SetInter x y) (Resolve _ - (DMP (SetDiff x y) t1) (NDMP (SetDiff y x) t2)))) _ - ) - --- The following creates the ruleset - -createResolveTTRules() == - -- expand multivariate polynomial rules - mps := '(MP DMP NDMP) - mpRules := "append"/[SUBST(mp,'mpoly1,$mpolyTTRules) for mp in mps] - $Res := CONS('(t1 t2 x y), - EQSUBSTLIST($nameList,$abList,append($generalTTRules,mpRules))) - true - ---% resolveTM Rules - --- Same rules as for resolveTT, with two exceptions: --- Diff(x,y): removes y from x, if possible, failed otherwise --- SetIncl(x,y): y if x is a subset of y, failed otherwise - --- These first rules will be expanded for each of MP, DMP and NDMP - -$mpolyTMRules == '( _ - ((Resolve (mpoly1 x t1) (P t2)) . (Resolve t1 (P t2))) _ - ((Resolve (mpoly1 (x) t1) (UP x t2)) . (UP x (Resolve t1 t2))) _ - ((Resolve (mpoly1 x t1) (UP y t2)) . _ - (UP y (Resolve (mpoly1 (Diff x y) t1) t2))) _ - ((Resolve (UP x t1) (mpoly1 y t2)) . _ - (Resolve t1 (mpoly1 (Incl x y) t2))) _ - ((Resolve (VARIABLE x) (mpoly1 y t2)) . _ - (mpoly1 (Incl x y) (Resolve (I) t2))) _ - ((Resolve (mpoly1 x t1) (mpoly2 y t2)) . _ - (Resolve t1 (mpoly2 (SetIncl x y) t2))) _ - ((Resolve (mpoly1 x t1) (mpoly2 y t2)) . _ - (mpoly2 y (Resolve (mpoly1 (SetComp x y) t1) t2))) _ - ((Resolve (mpoly1 x t1) (mpoly2 y t2)) . _ - (Resolve (mpoly1 (SetDiff x y) t1) (mpoly2 y t2))) _ - ) - --- These are the general rules, excluding those above. - -$generalTMRules == '( _ - ((Resolve (VARIABLE x) (P t1)) . (P (Resolve (I) t1))) _ - ((Resolve (VARIABLE x) (UP y t1)) . _ - (UP (VarEqual x y) (Resolve (I) t1))) _ - ((Resolve (VARIABLE x) (UPS y t1)) . _ - (UPS (VarEqual x y) (Resolve (I) t1))) _ - ((Resolve (VARIABLE x) (CFPS y t1)) . _ - (CFPS (VarEqual x y) (Resolve (RN) t1))) _ - ((Resolve (VARIABLE x) (ELFPS y t1)) . _ - (ELFPS (VarEqual x y) (Resolve (RN) t1))) _ - ((Resolve (VARIABLE x) (EF t1)) . (EF t1)) _ - ((Resolve (L (L (SY))) (M _*_*)) . (M (P (I)))) _ - ((Resolve (L (L (SY))) (SM x _*_*)) . (SM x (P (I)))) _ - ((Resolve (L (L t1)) (M t2)) . (M (Resolve t1 t2))) _ - ((Resolve (L (L t1)) (SM x t2)) . (SM x (Resolve t1 t2))) _ - ((Resolve (L (L t1)) (RM x y t2)) . (RM x y (Resolve t1 t2))) _ - ((Resolve (SY) t1) . (Resolve (P (I)) t1)) _ - ((Resolve (VARIABLE x) t1) . (Resolve (P (I)) t1)) _ - ((Resolve (SM x t1) (M t2)) . (M (Resolve t1 t2))) _ - ((Resolve (RM x y t1) (M t2)) . (M (Resolve t1 t2))) _ - _ - ((Resolve (M t1) (L _*_*)) . (L (L t1))) _ - ((Resolve (SM x t1) (L _*_*)) . (L (L t1))) _ - ((Resolve (RM x y t1) (L _*_*)) . (L (L t1))) _ - ((Resolve (M t1) (L t2)) . (L (Resolve (L t1) t2))) _ - ((Resolve (SM x t1) (L t2)) . (L (Resolve (L t1) t2))) _ - ((Resolve (RM x y t1) (L t2)) . (L (Resolve (L t1) t2))) _ - _ - ((Resolve (M t1) (V _*_*)) . (V (V t1))) _ - ((Resolve (SM x t1) (V _*_*)) . (V (V t1))) _ - ((Resolve (RM x y t1) (V _*_*)) . (V (V t1))) _ - ((Resolve (M t1) (V t2)) . (V (Resolve (V t1) t2))) _ - ((Resolve (SM x t1) (V t2)) . (V (Resolve (V t1) t2))) _ - ((Resolve (RM x y t1) (V t2)) . (V (Resolve (V t1) t2))) _ - _ - ((Resolve (L t1) (V t2)) . (V (Resolve t1 t2))) _ - ((Resolve (V t1) (L t2)) . (L (Resolve t1 t2))) _ - ((Resolve (FF t1) (FR t2)) . (FR (Resolve t1 t2))) _ - ((Resolve (UP x t1) (P t2)) . (Resolve t1 (P t2))) _ - ) - --- Private abbreviation table for resolve rules -$resolveAbbreviations == '( _ - (P . Polynomial) _ - (G . Gaussian) _ - (L . List) _ - (M . Matrix) _ - (EQ . Equation) _ - (B . Boolean) _ - (SY . Symbol) _ - (I . Integer) _ - (SM . SquareMatrix) _ - (RM . RectangularMatrix) _ - (V . Vector) _ - (FF . FactoredForm) _ - (FR . FactoredRing) _ - (RN . RationalNumber) _ - (F . Float) _ - (OV . OrderedVariableList) _ - (UP . UnivariatePoly) _ - (DMP . DistributedMultivariatePolynomial) _ - (MP . MultivariatePolynomial) _ - (HDMP . HomogeneousDistributedMultivariatePolynomial) _ - (QF . QuotientField) _ - (RF . RationalFunction) _ - (RE . RadicalExtension) _ - (RR . RationalRadicals) _ - (UPS . UnivariatePowerSeries) _ - (CFPS . ContinuedFractionPowerSeries) _ - (ELFPS . EllipticFunctionPowerSeries) _ - (EF . ElementaryFunction) _ - (VARIABLE . Variable) _ - ) - -$newResolveAbbreviations == '( _ - (P . Polynomial) _ - (G . Complex) _ - (L . List) _ - (M . Matrix) _ - (EQ . Equation) _ - (B . Boolean) _ - (SY . Symbol) _ - (I . Integer) _ - (SM . SquareMatrix) _ - (RM . RectangularMatrix) _ - (V . Vector) _ - (FF . Factored) _ - (FR . Factored) _ - (F . Float) _ - (OV . OrderedVariableList) _ - (UP . UnivariatePolynomial) _ - (DMP . DistributedMultivariatePolynomial) _ - (MP . MultivariatePolynomial) _ - (HDMP . HomogeneousDistributedMultivariatePolynomial) _ - (QF . Fraction) _ - (UPS . UnivariatePowerSeries) _ - (VARIABLE . Variable) _ - ) - --- The following creates the ruleset - -createResolveTMRules() == - -- expand multivariate polynomial rules - mps := '(MP DMP NDMP) - mpRules0 := "append"/[SUBST(mp,'mpoly1,$mpolyTMRules) for mp in mps] - mpRules := "append"/[SUBST(mp,'mpoly2,mpRules0) for mp in mps] - $ResMode := CONS('(t1 t2 x y), - EQSUBSTLIST($nameList,$abList,append(mpRules,$generalTMRules))) - true - -createTypeEquivRules() == - -- used by eqType, for example - $TypeEQ := CONS('(t1), EQSUBSTLIST($nameList,$abList,'( - ((QF (P t1)) . (RF t1)) - ((QF (I)) . (RN)) - ((RE (RN)) . (RR)) ))) - $TypeEqui := CONS(CAR $TypeEQ, [[b,:a] for [a,:b] in CDR $TypeEQ]) - true - -initializeRuleSets() == - $abList: local := - ASSOCLEFT $newResolveAbbreviations - $nameList: local := - ASSOCRIGHT $newResolveAbbreviations - createResolveTTRules() - createResolveTMRules() - createTypeEquivRules() - $ruleSetsInitialized := true - true -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/server.boot b/src/interp/server.boot new file mode 100644 index 00000000..9bb1c271 --- /dev/null +++ b/src/interp/server.boot @@ -0,0 +1,223 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- 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. + + +import '"macros" +)package "BOOT" + +-- Scratchpad-II server + +-- Assoc list of interpreter frame names and unique integer identifiers + +$frameAlist := nil +$frameNumber := 0 +$currentFrameNum := 0 +$EndServerSession := false +$NeedToSignalSessionManager := false +$sockBufferLength := 9217 + +serverReadLine(stream) == +-- used in place of READ-LINE in a scratchpad server system. + FORCE_-OUTPUT() + not $SpadServer or not IS_-CONSOLE stream => + read_-line(stream) + IN_-STREAM: fluid := stream + _*EOF_*: fluid := NIL + line := + while not $EndServerSession and not _*EOF_* repeat + if $NeedToSignalSessionManager then + sockSendInt($SessionManager, $EndOfOutput) + $NeedToSignalSessionManager := false + action := serverSwitch() + action = $CallInterp => + l := read_-line(stream) + $NeedToSignalSessionManager := true + return l + action = $CreateFrame => + frameName := GENTEMP('"frame") + addNewInterpreterFrame(frameName) + $frameAlist := [[$frameNumber,:frameName], :$frameAlist] + $currentFrameNum := $frameNumber + sockSendInt($SessionManager, $frameNumber) + $frameNumber := $frameNumber + 1 + sockSendString($SessionManager, MKPROMPT()) + action = $SwitchFrames => + $currentFrameNum := sockGetInt($SessionManager) + currentFrame := LASSOC($currentFrameNum, $frameAlist) + changeToNamedInterpreterFrame currentFrame + action = $EndSession => + $EndServerSession := true + action = $LispCommand => + $NeedToSignalSessionManager := true + stringBuf := MAKE_-STRING $sockBufferLength + sockGetString($MenuServer, stringBuf, $sockBufferLength) + form := unescapeStringsInForm READ_-FROM_-STRING stringBuf + protectedEVAL form + action = $QuietSpadCommand => + $NeedToSignalSessionManager := true + executeQuietCommand() + action = $SpadCommand => + $NeedToSignalSessionManager := true + stringBuf := MAKE_-STRING 512 + sockGetString($MenuServer, stringBuf, 512) + CATCH('coerceFailure,CATCH('top__level, CATCH('SPAD__READER, + parseAndInterpret stringBuf))) + PRINC MKPROMPT() + FINISH_-OUTPUT() + action = $NonSmanSession => + $SpadServer := nil + action = $KillLispSystem => + BYE() + NIL + line => line + "" + +parseAndInterpret str == + $InteractiveMode :fluid := true + $BOOT: fluid := NIL + $SPAD: fluid := true + $e:fluid := $InteractiveFrame + $useNewParser => + ncParseAndInterpretString str + oldParseAndInterpret str + +oldParseAndInterpret str == + tree := string2SpadTree str + tree => processInteractive(parseTransform postTransform tree, NIL) + NIL + +executeQuietCommand() == + $QuietCommand: fluid := true + stringBuf := MAKE_-STRING 512 + sockGetString($MenuServer, stringBuf, 512) + CATCH('coerceFailure,CATCH('top__level, CATCH('SPAD__READER, + parseAndInterpret stringBuf))) + +-- Includued for compatability with old-parser systems +serverLoop() == + IN_-STREAM: fluid := CURINSTREAM + _*EOF_*: fluid := NIL + while not $EndServerSession and not _*EOF_* repeat + if $Prompt then (PRINC MKPROMPT(); FINISH_-OUTPUT()) + $Prompt := NIL + action := serverSwitch() + action = $CallInterp => + CATCH('coerceFailure,CATCH('top__level, CATCH('SPAD__READER, + parseAndInterpret read_-line(CURINSTREAM) ))) + PRINC MKPROMPT() + FINISH_-OUTPUT() + sockSendInt($SessionManager, $EndOfOutput) + action = $CreateFrame => + frameName := GENTEMP('"frame") + addNewInterpreterFrame(frameName) + $frameAlist := [[$frameNumber,:frameName], :$frameAlist] + $currentFrameNum := $frameNumber + sockSendInt($SessionManager, $frameNumber) + $frameNumber := $frameNumber + 1 + sockSendString($SessionManager, MKPROMPT()) + action = $SwitchFrames => + $currentFrameNum := sockGetInt($SessionManager) + currentFrame := LASSOC($currentFrameNum, $frameAlist) + changeToNamedInterpreterFrame currentFrame + action = $EndSession => + $EndServerSession := true + action = $LispCommand => + stringBuf := MAKE_-STRING 512 + sockGetString($MenuServer, stringBuf, 512) + form := unescapeStringsInForm READ_-FROM_-STRING stringBuf + EVAL form + action = $QuietSpadCommand => + executeQuietCommand() + action = $SpadCommand => + stringBuf := MAKE_-STRING 512 + sockGetString($MenuServer, stringBuf, 512) + CATCH('coerceFailure,CATCH('top__level, CATCH('SPAD__READER, + parseAndInterpret stringBuf))) + PRINC MKPROMPT() + FINISH_-OUTPUT() + sockSendInt($SessionManager, $EndOfOutput) + NIL + if _*EOF_* then $Prompt := true + NIL + +parseAndEvalToHypertex str == + lines := parseAndEvalToStringForHypertex str + len := LENGTH lines + sockSendInt($MenuServer, len) + for s in lines repeat + sockSendString($MenuServer, s) + +parseAndEvalToString str == + $collectOutput:local := true + $outputLines: local := nil + $IOindex: local := nil + v := CATCH('SPAD__READER, CATCH('top__level, parseAndEvalStr str)) + v = 'restart => ['"error"] + NREVERSE $outputLines + +parseAndEvalToStringForHypertex str == + $collectOutput:local := true + $outputLines: local := nil + v := CATCH('SPAD__READER, CATCH('top__level, parseAndEvalStr str)) + v = 'restart => ['"error"] + NREVERSE $outputLines + +parseAndEvalToStringEqNum str == + $collectOutput:local := true + $outputLines: local := nil + v := CATCH('SPAD__READER, CATCH('top__level, parseAndEvalStr str)) + v = 'restart => ['"error"] + NREVERSE $outputLines + +parseAndInterpToString str == + v := applyWithOutputToString('parseAndEvalStr, [str]) + breakIntoLines CDR v + +parseAndEvalStr string == + $InteractiveMode :fluid := true + $BOOT: fluid := NIL + $SPAD: fluid := true + $e:fluid := $InteractiveFrame + parseAndEvalStr1 string + +parseAndEvalStr1 string == + string.0 = char '")" => + doSystemCommand SUBSEQ(string, 1) + processInteractive(ncParseFromString string, NIL) + +protectedEVAL x == + error := true + val := NIL + UNWIND_-PROTECT((val := EVAL x; error := NIL), + error => (resetStackLimits(); sendHTErrorSignal())) + val diff --git a/src/interp/server.boot.pamphlet b/src/interp/server.boot.pamphlet deleted file mode 100644 index ae0bfcc1..00000000 --- a/src/interp/server.boot.pamphlet +++ /dev/null @@ -1,243 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp server.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\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. - -@ -<<*>>= -<> - -import '"macros" -)package "BOOT" - --- Scratchpad-II server - --- Assoc list of interpreter frame names and unique integer identifiers - -$frameAlist := nil -$frameNumber := 0 -$currentFrameNum := 0 -$EndServerSession := false -$NeedToSignalSessionManager := false -$sockBufferLength := 9217 - -serverReadLine(stream) == --- used in place of READ-LINE in a scratchpad server system. - FORCE_-OUTPUT() - not $SpadServer or not IS_-CONSOLE stream => - read_-line(stream) - IN_-STREAM: fluid := stream - _*EOF_*: fluid := NIL - line := - while not $EndServerSession and not _*EOF_* repeat - if $NeedToSignalSessionManager then - sockSendInt($SessionManager, $EndOfOutput) - $NeedToSignalSessionManager := false - action := serverSwitch() - action = $CallInterp => - l := read_-line(stream) - $NeedToSignalSessionManager := true - return l - action = $CreateFrame => - frameName := GENTEMP('"frame") - addNewInterpreterFrame(frameName) - $frameAlist := [[$frameNumber,:frameName], :$frameAlist] - $currentFrameNum := $frameNumber - sockSendInt($SessionManager, $frameNumber) - $frameNumber := $frameNumber + 1 - sockSendString($SessionManager, MKPROMPT()) - action = $SwitchFrames => - $currentFrameNum := sockGetInt($SessionManager) - currentFrame := LASSOC($currentFrameNum, $frameAlist) - changeToNamedInterpreterFrame currentFrame - action = $EndSession => - $EndServerSession := true - action = $LispCommand => - $NeedToSignalSessionManager := true - stringBuf := MAKE_-STRING $sockBufferLength - sockGetString($MenuServer, stringBuf, $sockBufferLength) - form := unescapeStringsInForm READ_-FROM_-STRING stringBuf - protectedEVAL form - action = $QuietSpadCommand => - $NeedToSignalSessionManager := true - executeQuietCommand() - action = $SpadCommand => - $NeedToSignalSessionManager := true - stringBuf := MAKE_-STRING 512 - sockGetString($MenuServer, stringBuf, 512) - CATCH('coerceFailure,CATCH('top__level, CATCH('SPAD__READER, - parseAndInterpret stringBuf))) - PRINC MKPROMPT() - FINISH_-OUTPUT() - action = $NonSmanSession => - $SpadServer := nil - action = $KillLispSystem => - BYE() - NIL - line => line - "" - -parseAndInterpret str == - $InteractiveMode :fluid := true - $BOOT: fluid := NIL - $SPAD: fluid := true - $e:fluid := $InteractiveFrame - $useNewParser => - ncParseAndInterpretString str - oldParseAndInterpret str - -oldParseAndInterpret str == - tree := string2SpadTree str - tree => processInteractive(parseTransform postTransform tree, NIL) - NIL - -executeQuietCommand() == - $QuietCommand: fluid := true - stringBuf := MAKE_-STRING 512 - sockGetString($MenuServer, stringBuf, 512) - CATCH('coerceFailure,CATCH('top__level, CATCH('SPAD__READER, - parseAndInterpret stringBuf))) - --- Includued for compatability with old-parser systems -serverLoop() == - IN_-STREAM: fluid := CURINSTREAM - _*EOF_*: fluid := NIL - while not $EndServerSession and not _*EOF_* repeat - if $Prompt then (PRINC MKPROMPT(); FINISH_-OUTPUT()) - $Prompt := NIL - action := serverSwitch() - action = $CallInterp => - CATCH('coerceFailure,CATCH('top__level, CATCH('SPAD__READER, - parseAndInterpret read_-line(CURINSTREAM) ))) - PRINC MKPROMPT() - FINISH_-OUTPUT() - sockSendInt($SessionManager, $EndOfOutput) - action = $CreateFrame => - frameName := GENTEMP('"frame") - addNewInterpreterFrame(frameName) - $frameAlist := [[$frameNumber,:frameName], :$frameAlist] - $currentFrameNum := $frameNumber - sockSendInt($SessionManager, $frameNumber) - $frameNumber := $frameNumber + 1 - sockSendString($SessionManager, MKPROMPT()) - action = $SwitchFrames => - $currentFrameNum := sockGetInt($SessionManager) - currentFrame := LASSOC($currentFrameNum, $frameAlist) - changeToNamedInterpreterFrame currentFrame - action = $EndSession => - $EndServerSession := true - action = $LispCommand => - stringBuf := MAKE_-STRING 512 - sockGetString($MenuServer, stringBuf, 512) - form := unescapeStringsInForm READ_-FROM_-STRING stringBuf - EVAL form - action = $QuietSpadCommand => - executeQuietCommand() - action = $SpadCommand => - stringBuf := MAKE_-STRING 512 - sockGetString($MenuServer, stringBuf, 512) - CATCH('coerceFailure,CATCH('top__level, CATCH('SPAD__READER, - parseAndInterpret stringBuf))) - PRINC MKPROMPT() - FINISH_-OUTPUT() - sockSendInt($SessionManager, $EndOfOutput) - NIL - if _*EOF_* then $Prompt := true - NIL - -parseAndEvalToHypertex str == - lines := parseAndEvalToStringForHypertex str - len := LENGTH lines - sockSendInt($MenuServer, len) - for s in lines repeat - sockSendString($MenuServer, s) - -parseAndEvalToString str == - $collectOutput:local := true - $outputLines: local := nil - $IOindex: local := nil - v := CATCH('SPAD__READER, CATCH('top__level, parseAndEvalStr str)) - v = 'restart => ['"error"] - NREVERSE $outputLines - -parseAndEvalToStringForHypertex str == - $collectOutput:local := true - $outputLines: local := nil - v := CATCH('SPAD__READER, CATCH('top__level, parseAndEvalStr str)) - v = 'restart => ['"error"] - NREVERSE $outputLines - -parseAndEvalToStringEqNum str == - $collectOutput:local := true - $outputLines: local := nil - v := CATCH('SPAD__READER, CATCH('top__level, parseAndEvalStr str)) - v = 'restart => ['"error"] - NREVERSE $outputLines - -parseAndInterpToString str == - v := applyWithOutputToString('parseAndEvalStr, [str]) - breakIntoLines CDR v - -parseAndEvalStr string == - $InteractiveMode :fluid := true - $BOOT: fluid := NIL - $SPAD: fluid := true - $e:fluid := $InteractiveFrame - parseAndEvalStr1 string - -parseAndEvalStr1 string == - string.0 = char '")" => - doSystemCommand SUBSEQ(string, 1) - processInteractive(ncParseFromString string, NIL) - -protectedEVAL x == - error := true - val := NIL - UNWIND_-PROTECT((val := EVAL x; error := NIL), - error => (resetStackLimits(); sendHTErrorSignal())) - val -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/showimp.boot b/src/interp/showimp.boot index c6af476a..829aa5e5 100644 --- a/src/interp/showimp.boot +++ b/src/interp/showimp.boot @@ -1,5 +1,7 @@ -- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are diff --git a/src/interp/simpbool.boot b/src/interp/simpbool.boot new file mode 100644 index 00000000..d79829c2 --- /dev/null +++ b/src/interp/simpbool.boot @@ -0,0 +1,205 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- 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" + +simpBool x == dnf2pf reduceDnf be x + +reduceDnf u == +-- (OR (AND ..b..) b) ==> (OR b ) + atom u => u + for x in u repeat + ok := true + for y in u repeat + x = y => 'skip + dnfContains(x,y) => return (ok := false) + ok = true => acc := [x,:acc] + nreverse acc + +dnfContains([a,b],[c,d]) == fn(a,c) and fn(b,d) where + fn(x,y) == and/[member(u,x) for u in y] + +prove x == + world := [p for y in listOfUserIds x | (p := getPredicate y)] => + 'false = be mkpf([['NOT,x],:world],'AND) => true + 'false = be mkpf([x,:world],'AND) => false + x + 'false = (y := be x) => 'false + y = 'true => true + dnf2pf y + +simpBoolGiven(x,world) == + world => + 'false = be mkpf([['NOT,x],:world],'AND) => true + 'false = (y := be mkpf([x,:world],'AND)) => false + (u := andReduce(dnf2pf y,world)) is ['AND,:v] and + (w := SETDIFFERENCE(v,world)) ^= v => simpBool ['AND,:w] + u + 'false = (y := be x) => false + 'true = y => true + dnf2pf y + +andReduce(x,y) == + x is ['AND,:r] => + y is ['AND,:s] => mkpf(S_-(r,s),'AND) + mkpf(S_-(r,[s]),'AND) + x +dnf2pf(x) == + x = 'true => 'T + x = 'false => nil + atom x => x + mkpf( + [mkpf([:[k for k in b],:[['not,k] for k in a]],'AND) for [a,b] in x],'OR) +be x == b2dnf x +b2dnf x == + x = 'T => 'true + x = NIL => 'false + atom x => bassert x + [op,:argl] := x + MEMQ(op,'(AND and)) => band argl + MEMQ(op,'(OR or)) => bor argl + MEMQ(op,'(NOT not)) => bnot first argl + bassert x +band x == + x is [h,:t] => andDnf(b2dnf h,band t) + 'true +bor x == + x is [a,:b] => orDnf(b2dnf a,bor b) + 'false +bnot x == notDnf b2dnf x +bassert x == [[nil,[x]]] +bassertNot x == [[[x],nil]] +------------------------Disjunctive Normal Form Code----------------------- +-- dnf is true | false | [coaf ... ] +-- coaf is true | false | [item ... ] +-- item is anything + +orDnf(a,b) == -- or: (dnf, dnf) -> dnf + a = 'false => b + b = 'false => a + a = 'true or b = 'true => 'true + null a => b --null list means false + a is [c] = coafOrDnf(c,b) + coafOrDnf(first a,orDnf(rest a,b)) + +andDnf(a,b) == -- and: (dnf, dnf) -> dnf + a = 'true => b + b = 'true => a + a = 'false or b = 'false => 'false + null a => 'false --null list means false + a is [c] => coafAndDnf(c,b) + x := coafAndDnf(first a,b) + y := andDnf(rest a,b) + x = 'false => y + y = 'false => x + ordUnion(x,y) + +notDnf l == -- not: dnf -> dnf + l = 'true => 'false + l = 'false => 'true + null l => 'true --null list means false + l is [x] => notCoaf x + andDnf(notCoaf first l,notDnf rest l) + +coafOrDnf(a,l) == -- or: (coaf, dnf) -> dnf + a = 'true or l = 'true => 'true + a = 'false => l + member(a,l) => l + y := notCoaf a + x := ordIntersection(y,l) + null x => orDel(a,l) + x = l => 'true + x = y => ordSetDiff(l,x) + ordUnion(notDnf ordSetDiff(y,x),l) + +coafAndDnf(a,b) == --and: (coaf, dnf) -> dnf + a = 'true => b + a = 'false => 'false + [c,:r] := b + null r => coafAndCoaf(a,c) + x := coafAndCoaf(a,c) --dnf + y := coafAndDnf(a,r) --dnf + x = 'false => y + y = 'false => x + ordUnion(x,y) + +coafAndCoaf([a,b],[p,q]) == --and: (coaf,coaf) -> dnf + ordIntersection(a,q) or ordIntersection(b,p) => 'false + [[ordUnion(a,p),ordUnion(b,q)]] + +notCoaf [a,b] == [:[[nil,[x]] for x in a],:[[[x],nil] for x in b]] + +list1 l == + l isnt [h,:t] => nil + null h => list1 t + [[h,nil,nil],:list1 t] +list2 l == + l isnt [h,:t] => nil + null h => list2 t + [[nil,h,nil],:list2 t] +list3 l == + l isnt [h,:t] => nil + null h => list3 t + [[nil,nil,h],:list3 t] +orDel(a,l) == + l is [h,:t] => + a = h => t + ?ORDER(a,h) => [a,:l] + [h,:orDel(a,t)] + [a] +ordList l == + l is [h,:t] and t => orDel(h,ordList t) + l +ordUnion(a,b) == + a isnt [c,:r] => b + b isnt [d,:s] => a + c=d => [c,:ordUnion(r,s)] + ?ORDER(a,b) => [c,:ordUnion(r,b)] + [d,:ordUnion(s,a)] +ordIntersection(a,b) == + a isnt [h,:t] => nil + member(h,b) => [h,:ordIntersection(t,b)] + ordIntersection(t,b) +ordSetDiff(a,b) == + b isnt [h,:t] => a + member(h,a) => ordSetDiff(delete(h,a),t) + ordSetDiff(a,t) +------------- +testPredList u == + for x in u repeat + y := simpBool x + x = y => nil + pp x + pp '"==========>" + pp y diff --git a/src/interp/simpbool.boot.pamphlet b/src/interp/simpbool.boot.pamphlet deleted file mode 100644 index 88021ab9..00000000 --- a/src/interp/simpbool.boot.pamphlet +++ /dev/null @@ -1,225 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp simpbool.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\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" - -simpBool x == dnf2pf reduceDnf be x - -reduceDnf u == --- (OR (AND ..b..) b) ==> (OR b ) - atom u => u - for x in u repeat - ok := true - for y in u repeat - x = y => 'skip - dnfContains(x,y) => return (ok := false) - ok = true => acc := [x,:acc] - nreverse acc - -dnfContains([a,b],[c,d]) == fn(a,c) and fn(b,d) where - fn(x,y) == and/[member(u,x) for u in y] - -prove x == - world := [p for y in listOfUserIds x | (p := getPredicate y)] => - 'false = be mkpf([['NOT,x],:world],'AND) => true - 'false = be mkpf([x,:world],'AND) => false - x - 'false = (y := be x) => 'false - y = 'true => true - dnf2pf y - -simpBoolGiven(x,world) == - world => - 'false = be mkpf([['NOT,x],:world],'AND) => true - 'false = (y := be mkpf([x,:world],'AND)) => false - (u := andReduce(dnf2pf y,world)) is ['AND,:v] and - (w := SETDIFFERENCE(v,world)) ^= v => simpBool ['AND,:w] - u - 'false = (y := be x) => false - 'true = y => true - dnf2pf y - -andReduce(x,y) == - x is ['AND,:r] => - y is ['AND,:s] => mkpf(S_-(r,s),'AND) - mkpf(S_-(r,[s]),'AND) - x -dnf2pf(x) == - x = 'true => 'T - x = 'false => nil - atom x => x - mkpf( - [mkpf([:[k for k in b],:[['not,k] for k in a]],'AND) for [a,b] in x],'OR) -be x == b2dnf x -b2dnf x == - x = 'T => 'true - x = NIL => 'false - atom x => bassert x - [op,:argl] := x - MEMQ(op,'(AND and)) => band argl - MEMQ(op,'(OR or)) => bor argl - MEMQ(op,'(NOT not)) => bnot first argl - bassert x -band x == - x is [h,:t] => andDnf(b2dnf h,band t) - 'true -bor x == - x is [a,:b] => orDnf(b2dnf a,bor b) - 'false -bnot x == notDnf b2dnf x -bassert x == [[nil,[x]]] -bassertNot x == [[[x],nil]] -------------------------Disjunctive Normal Form Code----------------------- --- dnf is true | false | [coaf ... ] --- coaf is true | false | [item ... ] --- item is anything - -orDnf(a,b) == -- or: (dnf, dnf) -> dnf - a = 'false => b - b = 'false => a - a = 'true or b = 'true => 'true - null a => b --null list means false - a is [c] = coafOrDnf(c,b) - coafOrDnf(first a,orDnf(rest a,b)) - -andDnf(a,b) == -- and: (dnf, dnf) -> dnf - a = 'true => b - b = 'true => a - a = 'false or b = 'false => 'false - null a => 'false --null list means false - a is [c] => coafAndDnf(c,b) - x := coafAndDnf(first a,b) - y := andDnf(rest a,b) - x = 'false => y - y = 'false => x - ordUnion(x,y) - -notDnf l == -- not: dnf -> dnf - l = 'true => 'false - l = 'false => 'true - null l => 'true --null list means false - l is [x] => notCoaf x - andDnf(notCoaf first l,notDnf rest l) - -coafOrDnf(a,l) == -- or: (coaf, dnf) -> dnf - a = 'true or l = 'true => 'true - a = 'false => l - member(a,l) => l - y := notCoaf a - x := ordIntersection(y,l) - null x => orDel(a,l) - x = l => 'true - x = y => ordSetDiff(l,x) - ordUnion(notDnf ordSetDiff(y,x),l) - -coafAndDnf(a,b) == --and: (coaf, dnf) -> dnf - a = 'true => b - a = 'false => 'false - [c,:r] := b - null r => coafAndCoaf(a,c) - x := coafAndCoaf(a,c) --dnf - y := coafAndDnf(a,r) --dnf - x = 'false => y - y = 'false => x - ordUnion(x,y) - -coafAndCoaf([a,b],[p,q]) == --and: (coaf,coaf) -> dnf - ordIntersection(a,q) or ordIntersection(b,p) => 'false - [[ordUnion(a,p),ordUnion(b,q)]] - -notCoaf [a,b] == [:[[nil,[x]] for x in a],:[[[x],nil] for x in b]] - -list1 l == - l isnt [h,:t] => nil - null h => list1 t - [[h,nil,nil],:list1 t] -list2 l == - l isnt [h,:t] => nil - null h => list2 t - [[nil,h,nil],:list2 t] -list3 l == - l isnt [h,:t] => nil - null h => list3 t - [[nil,nil,h],:list3 t] -orDel(a,l) == - l is [h,:t] => - a = h => t - ?ORDER(a,h) => [a,:l] - [h,:orDel(a,t)] - [a] -ordList l == - l is [h,:t] and t => orDel(h,ordList t) - l -ordUnion(a,b) == - a isnt [c,:r] => b - b isnt [d,:s] => a - c=d => [c,:ordUnion(r,s)] - ?ORDER(a,b) => [c,:ordUnion(r,b)] - [d,:ordUnion(s,a)] -ordIntersection(a,b) == - a isnt [h,:t] => nil - member(h,b) => [h,:ordIntersection(t,b)] - ordIntersection(t,b) -ordSetDiff(a,b) == - b isnt [h,:t] => a - member(h,a) => ordSetDiff(delete(h,a),t) - ordSetDiff(a,t) -------------- -testPredList u == - for x in u repeat - y := simpBool x - x = y => nil - pp x - pp '"==========>" - pp y -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/slam.boot b/src/interp/slam.boot new file mode 100644 index 00000000..d9832a9a --- /dev/null +++ b/src/interp/slam.boot @@ -0,0 +1,338 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- 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. + + +import '"g-timer" +)package "BOOT" + +reportFunctionCompilation(op,nam,argl,body,isRecursive) == + -- for an alternate definition of this function which does not allow + -- dynamic caching, see SLAMOLD BOOT +--+ + $compiledOpNameList := [nam] + minivectorName := makeInternalMapMinivectorName(nam) + $minivectorNames := [[op,:minivectorName],:$minivectorNames] + body := SUBST(minivectorName,"$$$",body) + if $compilingInputFile then + $minivectorCode := [:$minivectorCode,minivectorName] + SET(minivectorName,LIST2REFVEC $minivector) + argl := COPY argl -- play it safe for optimization + init := + not(isRecursive and $compileRecurrence and #argl = 1) => nil + NRTisRecurrenceRelation(nam,body,minivectorName) + init => compileRecurrenceRelation(op,nam,argl,body,init) + cacheCount:= getCacheCount op + cacheCount = "all" => reportFunctionCacheAll(op,nam,argl,body) + cacheCount = 0 or null argl => + function:= [nam,['LAMBDA,[:argl,'envArg],body]] + compileInteractive function + nam + num := + FIXP cacheCount => + cacheCount < 1 => + keyedSystemError("S2IM0019",[cacheCount,op]) + cacheCount + keyedSystemError("S2IM0019",[cacheCount,op]) + sayKeyedMsg("S2IX0003",[op,num]) + auxfn := mkAuxiliaryName nam + g1:= GENSYM() --argument or argument list + [arg,computeValue] := + null argl => [nil,[auxfn]] + argl is [.] => [[g1, 'envArg],[auxfn,g1, 'envArg]] --g1 is a parameter + [g1,['APPLX,MKQ auxfn,g1]] --g1 is a parameter list + cacheName := mkCacheName nam + g2:= GENSYM() --length of cache or arg-value pair + g3:= GENSYM() --value computed by calling function + secondPredPair:= + null argl => [cacheName] + [['SETQ,g3,['assocCircular,g1,cacheName]],['CDR,g3]] + thirdPredPair:= + null argl => ['(QUOTE T),['SETQ,cacheName,computeValue]] + ['(QUOTE T), + ['SETQ,g2,computeValue], + ['SETQ,g3, + ['CAR,['SETQ,cacheName,['predCircular,cacheName,cacheCount]]]], + ['RPLACA,g3,g1], + ['RPLACD,g3,g2], + g2] + codeBody:= + ['PROG,[g2,g3],['RETURN,['COND,secondPredPair,thirdPredPair]]] + -- cannot use envArg in next statement without redoing much + -- of above. + lamex:= ['LAM,arg,codeBody] + mainFunction:= [nam,lamex] + computeFunction:= [auxfn,['LAMBDA,[:argl, 'envArg],body]] + compileInteractive mainFunction + compileInteractive computeFunction + cacheType:= 'function + cacheResetCode:= ['SETQ,cacheName,['mkCircularAlist,cacheCount]] + cacheCountCode:= ['countCircularAlist,cacheName,cacheCount] + cacheVector:= + mkCacheVec(op,cacheName,cacheType,cacheResetCode,cacheCountCode) + $e:= put(nam,'cacheInfo, cacheVector,$e) + eval cacheResetCode + SETANDFILE(cacheName,mkCircularAlist cacheCount) + nam + +getCacheCount fn == + n:= LASSOC(fn,$cacheAlist) => n + $cacheCount + +reportFunctionCacheAll(op,nam,argl,body) == + sayKeyedMsg("S2IX0004",[op]) + auxfn:= mkAuxiliaryName nam + g1:= GENSYM() --argument or argument list + [arg,computeValue] := + null argl => [['envArg],[auxfn, 'envArg]] + argl is [.] => [[g1, 'envArg],[auxfn,g1, 'envArg]] --g1 is a parameter + [g1,['APPLX,MKQ auxfn,g1]] --g1 is a parameter list + if null argl then g1:=nil + cacheName:= mkCacheName nam + g2:= GENSYM() --value computed by calling function + secondPredPair:= [['SETQ,g2,['HGET,cacheName,g1]],g2] + thirdPredPair:= ['(QUOTE T),['HPUT,cacheName,g1,computeValue]] + codeBody:= ['PROG,[g2],['RETURN,['COND,secondPredPair,thirdPredPair]]] + lamex:= ['LAM,arg,codeBody] + mainFunction:= [nam,lamex] + computeFunction:= [auxfn,['LAMBDA,[:argl, 'envArg],body]] + compileInteractive mainFunction + compileInteractive computeFunction + cacheType:= 'hash_-table + cacheResetCode:= ['SETQ,cacheName,['MAKE_-HASHTABLE,''UEQUAL]] + cacheCountCode:= ['hashCount,cacheName] + cacheVector:= + mkCacheVec(op,cacheName,cacheType,cacheResetCode,cacheCountCode) + $e:= put(nam,'cacheInfo, cacheVector,$e) + eval cacheResetCode + nam + +hashCount table == + +/[ADD1 nodeCount HGET(table,key) for key in HKEYS table] + +mkCircularAlist n == + l:= [[$failed,:$failed] for i in 1..n] + RPLACD(LASTNODE l,l) + +countCircularAlist(cal,n) == + +/[nodeCount x for x in cal for i in 1..n] + +predCircular(al,n) == + for i in 1..QSSUB1 n repeat al:= QCDR al + al + +assocCircular(x,al) == --like ASSOC except that al is circular + forwardPointer:= al + val:= nil + until EQ(forwardPointer,al) repeat + EQUAL(CAAR forwardPointer,x) => return (val:= CAR forwardPointer) + forwardPointer:= CDR forwardPointer + val + +compileRecurrenceRelation(op,nam,argl,junk,[body,sharpArg,n,:initCode]) == + k:= #initCode + extraArgumentCode := + extraArguments := [x for x in argl | x ^= sharpArg] => + extraArguments is [x] => x + ['LIST,:extraArguments] + nil + g:= GENSYM() + gIndex:= GENSYM() + gsList:= [GENSYM() for x in initCode] + auxfn := mkAuxiliaryName(nam) + $compiledOpNameList := [:$compiledOpNameList,auxfn] + stateNam:= GENVAR() + stateVar:= GENSYM() + stateVal:= GENSYM() + lastArg := INTERNL STRCONC('"#",STRINGIMAGE QSADD1 LENGTH argl) + decomposeCode:= + [['LET,gIndex,['ELT,lastArg,0]],:[['LET,g,['ELT,lastArg,i]] + for g in gsList for i in 1..]] + gsRev:= REVERSE gsList + rotateCode:= [['LET,p,q] for p in gsRev for q in [:rest gsRev,g]] + advanceCode:= ['LET,gIndex,['ADD1,gIndex]] + + newTripleCode := ['LIST,sharpArg,:gsList] + newStateCode := + null extraArguments => ['SETQ,stateNam,newTripleCode] + ['HPUT,stateNam,extraArgumentCode,newTripleCode] + + computeFunction:= [auxfn,['LAM,cargl,cbody]] where + cargl:= [:argl,lastArg] + returnValue:= ['PROGN,newStateCode,first gsList] + cbody:= + endTest:= + ['COND, [['EQL,sharpArg,gIndex],['RETURN,returnValue]]] + newValueCode:= ['LET,g,SUBST(gIndex,sharpArg, + EQSUBSTLIST(gsList,rest $TriangleVariableList,body))] + ['PROGN,:decomposeCode, + ['REPEAT,['WHILE,'T],['PROGN,endTest,advanceCode, + newValueCode,:rotateCode]]] + fromScratchInit:= + [['LET,gIndex,n],:[['LET,g,x] for g in gsList for x in initCode]] + continueInit:= + [['LET,gIndex,['ELT,stateVar,0]], + :[['LET,g,['ELT,stateVar,i]] for g in gsList for i in 1..]] + mainFunction:= [nam,['LAM,margl,mbody]] where + margl:= [:argl,'envArg] + max:= GENSYM() + tripleCode := ['CONS,n,['LIST,:initCode]] + + -- initialSetCode initializes the global variable if necessary and + -- also binds "stateVar" to its current value + initialSetCode := + initialValueCode := + extraArguments => ['MAKE_-HASHTABLE,''UEQUAL] + tripleCode + cacheResetCode := ['SETQ,stateNam,initialValueCode] + ['COND,[['NULL,['AND,['BOUNDP,MKQ stateNam], _ + ['PAIRP,stateNam]]], _ + ['LET,stateVar,cacheResetCode]], _ + [''T, ['LET,stateVar,stateNam]]] + + -- when there are extra arguments, initialResetCode resets "stateVar" + -- to the hashtable entry for the extra arguments + initialResetCode := + null extraArguments => nil + [['LET,stateVar,['OR, + ['HGET,stateVar,extraArgumentCode], + ['HPUT,stateVar,extraArgumentCode,tripleCode]]]] + + mbody := + preset := [initialSetCode,:initialResetCode,['LET,max,['ELT,stateVar,0]]] + phrase1:= [['AND,['LET,max,['ELT,stateVar,0]],['GE,sharpArg,max]], + [auxfn,:argl,stateVar]] + phrase2:= [['GT,sharpArg,['SETQ,max,['DIFFERENCE,max,k]]], + ['ELT,stateVar,['QSADD1,['QSDIFFERENCE,k,['DIFFERENCE,sharpArg,max]]]]] + phrase3:= [['GT,sharpArg,n],[auxfn,:argl,['LIST,n,:initCode]]] + phrase4:= [['GT,sharpArg,n-k], + ['ELT,['LIST,:initCode],['QSDIFFERENCE,n,sharpArg]]] + phrase5:= ['(QUOTE T),['recurrenceError,MKQ op,sharpArg]] + ['PROGN,:preset,['COND,phrase1,phrase2,phrase3,phrase4,phrase5]] + sayKeyedMsg("S2IX0001",[op]) + compileInteractive computeFunction + compileInteractive mainFunction + cacheType:= 'recurrence + cacheCountCode:= ['nodeCount,stateNam] + cacheVector:= mkCacheVec(op,stateNam,cacheType,cacheResetCode,cacheCountCode) + $e:= put(nam,'cacheInfo, cacheVector,$e) + nam + +nodeCount x == NUMOFNODES x + +recurrenceError(op,arg) == throwKeyedMsg("S2IX0002",[op,arg]) + +mkCacheVec(op,nam,kind,resetCode,countCode) == + [op,nam,kind,resetCode,countCode] + +-- reportCacheStore vl == +-- sayMSG concat(centerString('"Name",22,'" ")," Kind #Cells") +-- sayMSG concat(centerString('"----",22,'" ")," ---- ------") +-- for x in vl repeat reportCacheStoreFor x +-- +-- op2String op == +-- u:= linearFormatName op +-- atom u => PNAME u +-- "STRCONC"/u +-- +-- reportCacheStorePrint(op,kind,count) == +-- ops:= op2String op +-- opString:= centerString(ops,22,'" ") +-- kindString:= centerString(PNAME kind,10,'" ") +-- countString:= centerString(count,19,'" ") +-- sayMSG concat(opString,kindString,countString) +-- +-- reportCacheStoreFor op == +-- u:= getI(op,'localModemap) => +-- for [['local,target,:.],[.,fn],:.] in u repeat +-- [op1,cacheName,kind,.,countCode]:= getI(fn,'cacheInfo) or +-- keyedSystemError("S2GE0016",['"reportCacheStoreFor", +-- '"missing cache information vector"]) +-- reportCacheStorePrint(op,kind,eval countCode) +-- true +-- u:= getI(op,"cache") => +-- reportCacheStorePrint(op,'variable,nodeCount u) +-- nil + +clearCache x == + get(x,'localModemap,$e) or get(x,'mapBody,$e) => + for [map,:sub] in $mapSubNameAlist repeat + map=x => _/UNTRACE_,2(sub,NIL) + $e:= putHist(x,'localModemap,nil,$e) + $e:= putHist(x,'mapBody,nil,$e) + $e:= putHist(x,'localVars,nil,$e) + sayKeyedMsg("S2IX0007",[x]) + +clearLocalModemaps x == + u:= get(x,"localModemap",$e) => + for sub in ASSOCRIGHT $mapSubNameAlist repeat + _/UNTRACE_,2(sub,NIL) + $e:= putHist(x,"localModemap",nil,$e) + for mm in u repeat + [.,fn,:.] := mm + if def:= get(fn,'definition,$e) then + $e:= putHist(x,'value,mkObj(def,$EmptyMode),$e) + if cacheVec:= get(fn,'cacheInfo,$e) then + SET(cacheVec.cacheName,NIL) + -- now clear the property list of the identifier + $e := addIntSymTabBinding(x,nil,$e) + sayKeyedMsg("S2IX0007",[x]) + +compileInteractive fn == + if $InteractiveMode then startTimingProcess 'compilation + --following not used for common lisp + --removeUnnecessaryLastArguments CADR fn + if $reportCompilation then + sayBrightlyI bright '"Generated LISP code for function:" + pp fn + optfn := + $InteractiveMode => [timedOptimization fn] + [fn] + result := compQuietly optfn + if $InteractiveMode then stopTimingProcess 'compilation + result + +clearAllSlams x == + fn(x,nil) where + fn(thoseToClear,thoseCleared) == + for x in thoseToClear | not MEMQ(x,thoseCleared) repeat + slamListName:= mkCacheName x + SET(slamListName,nil) + thoseCleared:= ADJOIN(x,thoseCleared) + someMoreToClear:= + setDifference(LASSOC(x,$functorDependencyAlist),[:thoseToClear,: + thoseCleared]) + NCONC(thoseToClear,someMoreToClear) + +clearSlam("functor")== + id:= mkCacheName functor + SET(id,nil) diff --git a/src/interp/slam.boot.pamphlet b/src/interp/slam.boot.pamphlet deleted file mode 100644 index fe4f4c1c..00000000 --- a/src/interp/slam.boot.pamphlet +++ /dev/null @@ -1,360 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\File{src/interp/slam.boot} Pamphlet} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\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. - -@ -<<*>>= -<> - -import '"g-timer" -)package "BOOT" - -reportFunctionCompilation(op,nam,argl,body,isRecursive) == - -- for an alternate definition of this function which does not allow - -- dynamic caching, see SLAMOLD BOOT ---+ - $compiledOpNameList := [nam] - minivectorName := makeInternalMapMinivectorName(nam) - $minivectorNames := [[op,:minivectorName],:$minivectorNames] - body := SUBST(minivectorName,"$$$",body) - if $compilingInputFile then - $minivectorCode := [:$minivectorCode,minivectorName] - SET(minivectorName,LIST2REFVEC $minivector) - argl := COPY argl -- play it safe for optimization - init := - not(isRecursive and $compileRecurrence and #argl = 1) => nil - NRTisRecurrenceRelation(nam,body,minivectorName) - init => compileRecurrenceRelation(op,nam,argl,body,init) - cacheCount:= getCacheCount op - cacheCount = "all" => reportFunctionCacheAll(op,nam,argl,body) - cacheCount = 0 or null argl => - function:= [nam,['LAMBDA,[:argl,'envArg],body]] - compileInteractive function - nam - num := - FIXP cacheCount => - cacheCount < 1 => - keyedSystemError("S2IM0019",[cacheCount,op]) - cacheCount - keyedSystemError("S2IM0019",[cacheCount,op]) - sayKeyedMsg("S2IX0003",[op,num]) - auxfn := mkAuxiliaryName nam - g1:= GENSYM() --argument or argument list - [arg,computeValue] := - null argl => [nil,[auxfn]] - argl is [.] => [[g1, 'envArg],[auxfn,g1, 'envArg]] --g1 is a parameter - [g1,['APPLX,MKQ auxfn,g1]] --g1 is a parameter list - cacheName := mkCacheName nam - g2:= GENSYM() --length of cache or arg-value pair - g3:= GENSYM() --value computed by calling function - secondPredPair:= - null argl => [cacheName] - [['SETQ,g3,['assocCircular,g1,cacheName]],['CDR,g3]] - thirdPredPair:= - null argl => ['(QUOTE T),['SETQ,cacheName,computeValue]] - ['(QUOTE T), - ['SETQ,g2,computeValue], - ['SETQ,g3, - ['CAR,['SETQ,cacheName,['predCircular,cacheName,cacheCount]]]], - ['RPLACA,g3,g1], - ['RPLACD,g3,g2], - g2] - codeBody:= - ['PROG,[g2,g3],['RETURN,['COND,secondPredPair,thirdPredPair]]] - -- cannot use envArg in next statement without redoing much - -- of above. - lamex:= ['LAM,arg,codeBody] - mainFunction:= [nam,lamex] - computeFunction:= [auxfn,['LAMBDA,[:argl, 'envArg],body]] - compileInteractive mainFunction - compileInteractive computeFunction - cacheType:= 'function - cacheResetCode:= ['SETQ,cacheName,['mkCircularAlist,cacheCount]] - cacheCountCode:= ['countCircularAlist,cacheName,cacheCount] - cacheVector:= - mkCacheVec(op,cacheName,cacheType,cacheResetCode,cacheCountCode) - $e:= put(nam,'cacheInfo, cacheVector,$e) - eval cacheResetCode - SETANDFILE(cacheName,mkCircularAlist cacheCount) - nam - -getCacheCount fn == - n:= LASSOC(fn,$cacheAlist) => n - $cacheCount - -reportFunctionCacheAll(op,nam,argl,body) == - sayKeyedMsg("S2IX0004",[op]) - auxfn:= mkAuxiliaryName nam - g1:= GENSYM() --argument or argument list - [arg,computeValue] := - null argl => [['envArg],[auxfn, 'envArg]] - argl is [.] => [[g1, 'envArg],[auxfn,g1, 'envArg]] --g1 is a parameter - [g1,['APPLX,MKQ auxfn,g1]] --g1 is a parameter list - if null argl then g1:=nil - cacheName:= mkCacheName nam - g2:= GENSYM() --value computed by calling function - secondPredPair:= [['SETQ,g2,['HGET,cacheName,g1]],g2] - thirdPredPair:= ['(QUOTE T),['HPUT,cacheName,g1,computeValue]] - codeBody:= ['PROG,[g2],['RETURN,['COND,secondPredPair,thirdPredPair]]] - lamex:= ['LAM,arg,codeBody] - mainFunction:= [nam,lamex] - computeFunction:= [auxfn,['LAMBDA,[:argl, 'envArg],body]] - compileInteractive mainFunction - compileInteractive computeFunction - cacheType:= 'hash_-table - cacheResetCode:= ['SETQ,cacheName,['MAKE_-HASHTABLE,''UEQUAL]] - cacheCountCode:= ['hashCount,cacheName] - cacheVector:= - mkCacheVec(op,cacheName,cacheType,cacheResetCode,cacheCountCode) - $e:= put(nam,'cacheInfo, cacheVector,$e) - eval cacheResetCode - nam - -hashCount table == - +/[ADD1 nodeCount HGET(table,key) for key in HKEYS table] - -mkCircularAlist n == - l:= [[$failed,:$failed] for i in 1..n] - RPLACD(LASTNODE l,l) - -countCircularAlist(cal,n) == - +/[nodeCount x for x in cal for i in 1..n] - -predCircular(al,n) == - for i in 1..QSSUB1 n repeat al:= QCDR al - al - -assocCircular(x,al) == --like ASSOC except that al is circular - forwardPointer:= al - val:= nil - until EQ(forwardPointer,al) repeat - EQUAL(CAAR forwardPointer,x) => return (val:= CAR forwardPointer) - forwardPointer:= CDR forwardPointer - val - -compileRecurrenceRelation(op,nam,argl,junk,[body,sharpArg,n,:initCode]) == - k:= #initCode - extraArgumentCode := - extraArguments := [x for x in argl | x ^= sharpArg] => - extraArguments is [x] => x - ['LIST,:extraArguments] - nil - g:= GENSYM() - gIndex:= GENSYM() - gsList:= [GENSYM() for x in initCode] - auxfn := mkAuxiliaryName(nam) - $compiledOpNameList := [:$compiledOpNameList,auxfn] - stateNam:= GENVAR() - stateVar:= GENSYM() - stateVal:= GENSYM() - lastArg := INTERNL STRCONC('"#",STRINGIMAGE QSADD1 LENGTH argl) - decomposeCode:= - [['LET,gIndex,['ELT,lastArg,0]],:[['LET,g,['ELT,lastArg,i]] - for g in gsList for i in 1..]] - gsRev:= REVERSE gsList - rotateCode:= [['LET,p,q] for p in gsRev for q in [:rest gsRev,g]] - advanceCode:= ['LET,gIndex,['ADD1,gIndex]] - - newTripleCode := ['LIST,sharpArg,:gsList] - newStateCode := - null extraArguments => ['SETQ,stateNam,newTripleCode] - ['HPUT,stateNam,extraArgumentCode,newTripleCode] - - computeFunction:= [auxfn,['LAM,cargl,cbody]] where - cargl:= [:argl,lastArg] - returnValue:= ['PROGN,newStateCode,first gsList] - cbody:= - endTest:= - ['COND, [['EQL,sharpArg,gIndex],['RETURN,returnValue]]] - newValueCode:= ['LET,g,SUBST(gIndex,sharpArg, - EQSUBSTLIST(gsList,rest $TriangleVariableList,body))] - ['PROGN,:decomposeCode, - ['REPEAT,['WHILE,'T],['PROGN,endTest,advanceCode, - newValueCode,:rotateCode]]] - fromScratchInit:= - [['LET,gIndex,n],:[['LET,g,x] for g in gsList for x in initCode]] - continueInit:= - [['LET,gIndex,['ELT,stateVar,0]], - :[['LET,g,['ELT,stateVar,i]] for g in gsList for i in 1..]] - mainFunction:= [nam,['LAM,margl,mbody]] where - margl:= [:argl,'envArg] - max:= GENSYM() - tripleCode := ['CONS,n,['LIST,:initCode]] - - -- initialSetCode initializes the global variable if necessary and - -- also binds "stateVar" to its current value - initialSetCode := - initialValueCode := - extraArguments => ['MAKE_-HASHTABLE,''UEQUAL] - tripleCode - cacheResetCode := ['SETQ,stateNam,initialValueCode] - ['COND,[['NULL,['AND,['BOUNDP,MKQ stateNam], _ - ['PAIRP,stateNam]]], _ - ['LET,stateVar,cacheResetCode]], _ - [''T, ['LET,stateVar,stateNam]]] - - -- when there are extra arguments, initialResetCode resets "stateVar" - -- to the hashtable entry for the extra arguments - initialResetCode := - null extraArguments => nil - [['LET,stateVar,['OR, - ['HGET,stateVar,extraArgumentCode], - ['HPUT,stateVar,extraArgumentCode,tripleCode]]]] - - mbody := - preset := [initialSetCode,:initialResetCode,['LET,max,['ELT,stateVar,0]]] - phrase1:= [['AND,['LET,max,['ELT,stateVar,0]],['GE,sharpArg,max]], - [auxfn,:argl,stateVar]] - phrase2:= [['GT,sharpArg,['SETQ,max,['DIFFERENCE,max,k]]], - ['ELT,stateVar,['QSADD1,['QSDIFFERENCE,k,['DIFFERENCE,sharpArg,max]]]]] - phrase3:= [['GT,sharpArg,n],[auxfn,:argl,['LIST,n,:initCode]]] - phrase4:= [['GT,sharpArg,n-k], - ['ELT,['LIST,:initCode],['QSDIFFERENCE,n,sharpArg]]] - phrase5:= ['(QUOTE T),['recurrenceError,MKQ op,sharpArg]] - ['PROGN,:preset,['COND,phrase1,phrase2,phrase3,phrase4,phrase5]] - sayKeyedMsg("S2IX0001",[op]) - compileInteractive computeFunction - compileInteractive mainFunction - cacheType:= 'recurrence - cacheCountCode:= ['nodeCount,stateNam] - cacheVector:= mkCacheVec(op,stateNam,cacheType,cacheResetCode,cacheCountCode) - $e:= put(nam,'cacheInfo, cacheVector,$e) - nam - -nodeCount x == NUMOFNODES x - -recurrenceError(op,arg) == throwKeyedMsg("S2IX0002",[op,arg]) - -mkCacheVec(op,nam,kind,resetCode,countCode) == - [op,nam,kind,resetCode,countCode] - --- reportCacheStore vl == --- sayMSG concat(centerString('"Name",22,'" ")," Kind #Cells") --- sayMSG concat(centerString('"----",22,'" ")," ---- ------") --- for x in vl repeat reportCacheStoreFor x --- --- op2String op == --- u:= linearFormatName op --- atom u => PNAME u --- "STRCONC"/u --- --- reportCacheStorePrint(op,kind,count) == --- ops:= op2String op --- opString:= centerString(ops,22,'" ") --- kindString:= centerString(PNAME kind,10,'" ") --- countString:= centerString(count,19,'" ") --- sayMSG concat(opString,kindString,countString) --- --- reportCacheStoreFor op == --- u:= getI(op,'localModemap) => --- for [['local,target,:.],[.,fn],:.] in u repeat --- [op1,cacheName,kind,.,countCode]:= getI(fn,'cacheInfo) or --- keyedSystemError("S2GE0016",['"reportCacheStoreFor", --- '"missing cache information vector"]) --- reportCacheStorePrint(op,kind,eval countCode) --- true --- u:= getI(op,"cache") => --- reportCacheStorePrint(op,'variable,nodeCount u) --- nil - -clearCache x == - get(x,'localModemap,$e) or get(x,'mapBody,$e) => - for [map,:sub] in $mapSubNameAlist repeat - map=x => _/UNTRACE_,2(sub,NIL) - $e:= putHist(x,'localModemap,nil,$e) - $e:= putHist(x,'mapBody,nil,$e) - $e:= putHist(x,'localVars,nil,$e) - sayKeyedMsg("S2IX0007",[x]) - -clearLocalModemaps x == - u:= get(x,"localModemap",$e) => - for sub in ASSOCRIGHT $mapSubNameAlist repeat - _/UNTRACE_,2(sub,NIL) - $e:= putHist(x,"localModemap",nil,$e) - for mm in u repeat - [.,fn,:.] := mm - if def:= get(fn,'definition,$e) then - $e:= putHist(x,'value,mkObj(def,$EmptyMode),$e) - if cacheVec:= get(fn,'cacheInfo,$e) then - SET(cacheVec.cacheName,NIL) - -- now clear the property list of the identifier - $e := addIntSymTabBinding(x,nil,$e) - sayKeyedMsg("S2IX0007",[x]) - -compileInteractive fn == - if $InteractiveMode then startTimingProcess 'compilation - --following not used for common lisp - --removeUnnecessaryLastArguments CADR fn - if $reportCompilation then - sayBrightlyI bright '"Generated LISP code for function:" - pp fn - optfn := - $InteractiveMode => [timedOptimization fn] - [fn] - result := compQuietly optfn - if $InteractiveMode then stopTimingProcess 'compilation - result - -clearAllSlams x == - fn(x,nil) where - fn(thoseToClear,thoseCleared) == - for x in thoseToClear | not MEMQ(x,thoseCleared) repeat - slamListName:= mkCacheName x - SET(slamListName,nil) - thoseCleared:= ADJOIN(x,thoseCleared) - someMoreToClear:= - setDifference(LASSOC(x,$functorDependencyAlist),[:thoseToClear,: - thoseCleared]) - NCONC(thoseToClear,someMoreToClear) - -clearSlam("functor")== - id:= mkCacheName functor - SET(id,nil) -@ - -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/sys-constants.boot b/src/interp/sys-constants.boot index adca0eca..75896661 100644 --- a/src/interp/sys-constants.boot +++ b/src/interp/sys-constants.boot @@ -1,5 +1,7 @@ -- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are @@ -29,8 +31,6 @@ -- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- --- Copyright (C) 2007 Gabriel Dos Reis --- -- -- This file collects and documents some of the constants used by either diff --git a/src/interp/sys-driver.boot b/src/interp/sys-driver.boot index f33d9bc8..2bd991fa 100644 --- a/src/interp/sys-driver.boot +++ b/src/interp/sys-driver.boot @@ -1,5 +1,7 @@ -- Copyright (C) 2007 Gabriel Dos Reis -- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are diff --git a/src/interp/sys-globals.boot b/src/interp/sys-globals.boot index e01aca54..072c4ac0 100644 --- a/src/interp/sys-globals.boot +++ b/src/interp/sys-globals.boot @@ -1,5 +1,7 @@ -- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are diff --git a/src/interp/template.boot b/src/interp/template.boot index 06b03d7a..78018e07 100644 --- a/src/interp/template.boot +++ b/src/interp/template.boot @@ -1,5 +1,7 @@ -- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are diff --git a/src/interp/termrw.boot b/src/interp/termrw.boot index 6829defc..5b876b84 100644 --- a/src/interp/termrw.boot +++ b/src/interp/termrw.boot @@ -1,5 +1,7 @@ -- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are diff --git a/src/interp/topics.boot b/src/interp/topics.boot index 32a7d7bf..5ecc9dee 100644 --- a/src/interp/topics.boot +++ b/src/interp/topics.boot @@ -1,5 +1,7 @@ -- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are diff --git a/src/interp/trace.boot b/src/interp/trace.boot index 6cfd5d39..cb78d843 100644 --- a/src/interp/trace.boot +++ b/src/interp/trace.boot @@ -1,5 +1,7 @@ -- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are diff --git a/src/interp/varini.boot b/src/interp/varini.boot index aa70e21e..5b755d32 100644 --- a/src/interp/varini.boot +++ b/src/interp/varini.boot @@ -1,5 +1,7 @@ -- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are diff --git a/src/interp/wi1.boot b/src/interp/wi1.boot new file mode 100644 index 00000000..6d287d09 --- /dev/null +++ b/src/interp/wi1.boot @@ -0,0 +1,1263 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- 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" + +-- !! do not delete the next function ! + +spad2AsTranslatorAutoloadOnceTrigger() == nil + +pairList(u,v) == [[x,:y] for x in u for y in v] + +--====================================================================== +-- Temporary definitions---for tracing and debugging +--====================================================================== +tr fn == + $convertingSpadFile : local := true + $options: local := nil + sfn := STRINGIMAGE fn + newname := STRCONC(sfn,'".as") + $outStream :local := MAKE_-OUTSTREAM newname + markSay '"#pile" + markSay('"#include _"axiom.as_"") + markTerpri() + CATCH("SPAD__READER",compiler [INTERN sfn]) + SHUT $outStream + +stackMessage msg == +--if msg isnt ["cannot coerce: ",:.] then foobum msg + $compErrorMessageStack:= [msg,:$compErrorMessageStack] + nil + +ppFull x == + _*PRINT_-LEVEL_* : local := nil + _*PRINT_-DEPTH_* : local := nil + _*PRINT_-LENGTH_* : local := nil + pp x + +put(x,prop,val,e) == +--if prop = 'mode and CONTAINED('PART,val) then foobar val + $InteractiveMode and not EQ(e,$CategoryFrame) => + putIntSymTab(x,prop,val,e) + --e must never be $CapsuleModemapFrame + null atom x => put(first x,prop,val,e) + newProplist:= augProplistOf(x,prop,val,e) + prop="modemap" and $insideCapsuleFunctionIfTrue=true => + SAY ["**** modemap PUT on CapsuleModemapFrame: ",val] + $CapsuleModemapFrame:= + addBinding(x,augProplistOf(x,"modemap",val,$CapsuleModemapFrame), + $CapsuleModemapFrame) + e + addBinding(x,newProplist,e) + +addBinding(var,proplist,e is [[curContour,:tailContour],:tailEnv]) == +--if CONTAINED('PART,proplist) then foobar proplist + 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] + +--====================================================================== +-- From define.boot +--====================================================================== +compJoin(["Join",:argl],m,e) == + catList:= [(compForMode(x,$Category,e) or return 'failed).expr for x in argl] + catList='failed => stackSemanticError(["cannot form Join of: ",argl],nil) + catList':= + [extract for x in catList] where + extract() == + x := markKillAll x + isCategoryForm(x,e) => + parameters:= + union("append"/[getParms(y,e) for y in rest x],parameters) + where getParms(y,e) == + atom y => + isDomainForm(y,e) => LIST y + nil + y is ['LENGTH,y'] => [y,y'] + LIST y + x + x is ["DomainSubstitutionMacro",pl,body] => + (parameters:= union(pl,parameters); body) + x is ["mkCategory",:.] => x + atom x and getmode(x,e)=$Category => x + stackSemanticError(["invalid argument to Join: ",x],nil) + x + T:= [wrapDomainSub(parameters,["Join",:catList']),$Category,e] + convert(T,m) + + +compDefineFunctor(dfOriginal,m,e,prefix,fal) == + df := markInsertParts dfOriginal + $domainShell: local -- holds the category of the object being compiled + $profileCompiler: local := true + $profileAlist: local := nil + $LISPLIB => compDefineLisplib(df,m,e,prefix,fal,'compDefineFunctor1) + compDefineFunctor1(df,m,e,prefix,fal) + +compDefineLisplib(df,m,e,prefix,fal,fn) == + ["DEF",[op,:.],:.] := df + --fn= compDefineCategory OR compDefineFunctor + sayMSG fillerSpaces(72,'"-") + $LISPLIB: local := 'T + $op: local := op + $lisplibAttributes: local := NIL + $lisplibPredicates: local := NIL -- set by makePredicateBitVector + $lisplibCategoriesExtended: local := NIL -- this is always nil. why? (tpd) + $lisplibForm: local := NIL + $lisplibKind: local := NIL + $lisplibModemap: local := NIL + $lisplibModemapAlist: local := NIL + $lisplibSlot1 : local := NIL -- used by NRT mechanisms + $lisplibOperationAlist: local := NIL + $lisplibSuperDomain: local := NIL + $libFile: local := NIL + $lisplibVariableAlist: local := NIL + $lisplibRelatedDomains: local := NIL --from ++ Related Domains: see c-doc + $lisplibCategory: local := nil + --for categories, is rhs of definition; otherwise, is target of functor + --will eventually become the "constructorCategory" property in lisplib + --set in compDefineCategory if category, otherwise in finalizeLisplib + libName := getConstructorAbbreviation op + -- $incrementalLisplibFlag seems never to be set so next line not used + -- originalLisplibCategory:= getLisplib(libName,'constructorCategory) + BOUNDP '$compileDocumentation and $compileDocumentation => + compileDocumentation libName + sayMSG ['" initializing ",$spadLibFT,:bright libName, + '"for",:bright op] + initializeLisplib libName + sayMSG ['" compiling into ",$spadLibFT,:bright libName] + res:= FUNCALL(fn,df,m,e,prefix,fal) + sayMSG ['" finalizing ",$spadLibFT,:bright libName] +--finalizeLisplib libName + FRESH_-LINE $algebraOutputStream + sayMSG fillerSpaces(72,'"-") + unloadOneConstructor(op,libName) + res + +compTopLevel(x,m,e) == +--+ signals that target is derived from lhs-- see NRTmakeSlot1Info + $NRTderivedTargetIfTrue: local := false + $killOptimizeIfTrue: local:= false + $forceAdd: local:= false + $compTimeSum: local := 0 + $resolveTimeSum: local := 0 + $packagesUsed: local := [] + -- The next line allows the new compiler to be tested interactively. + compFun := if $newCompAtTopLevel=true then 'newComp else 'compOrCroak + if x is ["where",:.] then x := markWhereTran x + def := + x is ["where",a,:.] => a + x + $originalTarget : local := + def is ["DEF",.,[target,:.],:.] => target + 'sorry + x is ["DEF",:.] or x is ["where",["DEF",:.],:.] => + ([val,mode,.]:= FUNCALL(compFun,x,m,e); [val,mode,e]) + --keep old environment after top level function defs + FUNCALL(compFun,x,m,e) + +markWhereTran ["where",["DEF",form,sig,clist,body],:tail] == + items := + tail is [['SEQ,:l,['exit,n,x]]] => [:l,x] + [first tail] + [op,:argl] := form + [target,:atypeList] := sig + decls := [[":",a,b] for a in argl for b in atypeList | b] +-- not (and/[null x for x in atypeList]) => +-- systemError ['"unexpected WHERE argument list: ",:atypeList] + for x in items repeat + x is [":",a,b] => + a is ['LISTOF,:r] => + for y in r repeat decls := [[":",y,b],:decls] + decls := [x,:decls] + x is [key,fn,p,q,bd] and MEMQ(key,'(DEF MDEF)) and p='(NIL) and q='(NIL) => + fn = target or fn is [=target] => ttype := bd + fn = body or fn is [=body] => body := bd + macros := [x,:macros] + systemError ['"unexpected WHERE item: ",x] + nargtypes := [p for arg in argl | + p := or/[t for d in decls | d is [.,=arg,t]] or + systemError ['"Missing WHERE declaration for :", arg]] + nform := form + ntarget := ttype or target + ndef := ['DEF,nform,[ntarget,:nargtypes],clist,body] + result := + REVERSE macros is [:m,e] => + mpart := + m => ['SEQ,:m,['exit,1,e]] + e + ['where,ndef,mpart] + ndef + result + +compPART(u,m,e) == +--------new------------------------------------------94/10/11 + ['PART,.,x] := u + T := comp(x,m,e) => markAny('compPART,u, T) + nil + +xxxxx x == x + +qt(n,T) == + null T => nil + if null getProplist('R,T.env) then xxxxx n + T + +qe(n,e) == + if null getProplist('R,e) then xxxxx n + e + +comp(x,m,e) == + qe(7,e) + T := qt(8,comp0(x,m,e)) => qt(9,markComp(x,T)) +--T := m = "$" and comp(x,$EmptyMode,e) => coerce(T, m) + --------------------------------------------------------94/11/10 + nil + +comp0(x,m,e) == + qe(8,e) +--version of comp which skips the marking (see compReduce1) + T:= compNoStacking(x,m,e) => + $compStack:= nil + qt(10,T) + $compStack:= [[x,m,e,$exitModeStack],:$compStack] + nil + +compNoStacking(xOrig,m,e) == + $partExpression: local := nil + xOrig := markKillAllRecursive xOrig +-->xOrig is ['PART,n,x] => compNoStackingAux(xOrig,m,e) +----------------------------------------------------------94/10/11 + qt(11,compNoStacking0(xOrig,m,e)) + +markKillAllRecursive x == + x is [op,:r] => +--->op = 'PART => markKillAllRecursive CADR r + op = 'PART => ['PART, CAR r, markKillAllRecursive CADR r] +----------------------------------------------------------94/10/11 + constructor? op => markKillAll x + op = 'elt and constructor? opOf CAR r => + ['elt,markKillAllRecursive CAR r,CADR r] + x + x + +compNoStackingAux($partExpression,m,e) == +-----------------not used---------------------94/10/11 + x := CADDR $partExpression + T := compNoStacking0(x,m,e) or return nil + markParts($partExpression,T) + +compNoStacking0(x,m,e) == + qe(1,e) + T := compNoStacking01(x,m,qe(51,e)) + qt(52,T) + +compNoStacking01(x,m,e) == +--compNoStacking0(x,m,e) == + if CONTAINED('MI,m) then m := markKillAll(m) + T:= comp2(x,m,e) => + (m=$EmptyMode and T.mode=IFCAR(get('Rep,'value,e)) => + [T.expr,"Rep",T.env]; qt(12,T)) + --$Representation is bound in compDefineFunctor, set by doIt + --this hack says that when something is undeclared, $ is + --preferred to the underlying representation -- RDJ 9/12/83 + T := compNoStacking1(x,m,e,$compStack) + qt(13,T) + +compNoStacking1(x,m,e,$compStack) == + u:= get(if m="$" then "Rep" else m,"value",e) => + m1 := markKillAll u.expr +--------------------> new <------------------------- + T:= comp2(x,m1,e) => coerce(T,m) + nil +--------------------> new <------------------------- + nil + +compWithMappingMode(x,m,oldE) == + ["Mapping",m',:sl] := m + $killOptimizeIfTrue: local:= true + e:= oldE + x := markKillAll x + ------------------ + m := markKillAll m + ------------------ +--if x is ['PART,.,y] then x := y +--------------------------------- + isFunctor x => + if get(x,"modemap",$CategoryFrame) is [[[.,target,:argModeList],.],:.] and + (and/[extendsCategoryForm("$",s,mode) for mode in argModeList for s in sl] + ) and extendsCategoryForm("$",target,m') then return [x,m,e] + if STRINGP x then x:= INTERN x + for m in sl for v in (vl:= take(#sl,$FormalMapVariableList)) repeat + [.,.,e]:= compMakeDeclaration([":",v,m],$EmptyMode,e) + not null vl and not hasFormalMapVariable(x, vl) => return + [u,.,.] := comp([x,:vl],m',e) or return nil + extractCodeAndConstructTriple(u, m, oldE) + null vl and (t := comp([x], m', e)) => return + [u,.,.] := t + extractCodeAndConstructTriple(u, m, oldE) + [u,.,.]:= comp(x,m',e) or return nil + originalFun := u + if originalFun is ['WI,a,b] then u := b + uu := ['LAMBDA,vl,u] + --------------------------> 11/28 drop COMP-TRAN, optimizations + T := [uu,m,oldE] + originalFun is ['WI,a,b] => markLambda(vl,a,m,T) + markLambda(vl,originalFun,m,T) + +compAtom(x,m,e) == + T:= compAtomWithModemap(x,m,e,get(x,"modemap",e)) => markCompAtom(x,T) + x="nil" => + T:= + modeIsAggregateOf('List,m,e) is [.,R]=> compList(x,['List,R],e) + modeIsAggregateOf('Vector,m,e) is [.,R]=> compVector(x,['Vector,R],e) + T => convert(T,m) +--> + FIXP x and MEMQ(opOf m, '(Integer NonNegativeInteger PositiveInteger SmallInteger)) => markAt [x,m,e] +-- FIXP x and (T := [x, $Integer,e]) and (T' := convert(T,m)) => markAt(T, T') + t:= + isSymbol x => + compSymbol(x,m,e) or return nil + m = $Expression and primitiveType x => [x,m,e] + STRINGP x => + x ^= '"failed" and (member('(Symbol), $localImportStack) or + member('(Symbol), $globalImportStack)) => markAt [x, '(String), e] + [x, x, e] + [x,primitiveType x or return nil,e] + convert(t,m) + +extractCodeAndConstructTriple(u, m, oldE) == + u := markKillAll u + u is ["call",fn,:.] => + if fn is ["applyFun",a] then fn := a + [fn,m,oldE] + [op,:.,env] := u + [["CONS",["function",op],env],m,oldE] + +compSymbol(s,m,e) == + s="$NoValue" => ["$NoValue",$NoValueMode,e] + isFluid s => [s,getmode(s,e) or return nil,e] + s="true" => ['(QUOTE T),$Boolean,e] + s="false" => [false,$Boolean,e] + s=m or get(s,"isLiteral",e) => [["QUOTE",s],s,e] + v:= get(s,"value",e) => +--+ + MEMQ(s,$functorLocalParameters) => + NRTgetLocalIndex s + [s,v.mode,e] --s will be replaced by an ELT form in beforeCompile + [s,v.mode,e] --s has been SETQd + m':= getmode(s,e) => + if not member(s,$formalArgList) and not MEMQ(s,$FormalMapVariableList) and + not isFunction(s,e) and null ($compForModeIfTrue=true) then errorRef s + [s,m',e] --s is a declared argument + MEMQ(s,$FormalMapVariableList) => stackMessage ["no mode found for",s] +---> + m = $Symbol or m = $Expression => [['QUOTE,s],m,e] + ---> was ['QUOTE, s] + not isFunction(s,e) => errorRef s + +compForm(form,m,e) == + if form is [['PART,.,op],:r] then form := [op,:r] + ----------------------------------------------------- 94/10/16 + T:= + compForm1(form,m,e) or compArgumentsAndTryAgain(form,m,e) or return + stackMessageIfNone ["cannot compile","%b",form,"%d"] + T + +compForm1(form,m,e) == + [op,:argl] := form + $NumberOfArgsIfInteger: local:= #argl --see compElt + op="error" => + [[op,:[([.,.,e]:=outputComp(x,e)).expr + for x in argl]],m,e] + op is ['MI,a,b] => compForm1([markKillExpr b,:argl],m,e) + op is ["elt",domain,op'] => + domain := markKillAll domain + domain="Lisp" => + --op'='QUOTE and null rest argl => [first argl,m,e] + val := [op',:[([.,.,e]:= compOrCroak(x,$EmptyMode,e)).expr for x in argl]] + markLisp([val,m,e],m) +-------> new <------------- +-- foobar domain +-- markImport(domain,true) +-------> new <------------- + domain=$Expression and op'="construct" => compExpressionList(argl,m,e) + (op'="COLLECT") and coerceable(domain,m,e) => + (T:= comp([op',:argl],domain,e) or return nil; coerce(T,m)) +-------> new <------------- + domain= 'Rep and + (ans := compForm2([op',:argl],SUBST('Rep,'_$,m),e:= addDomain(domain,e), + [SUBST('Rep,'_$,x) for x in getFormModemaps([op',:argl],e) + | x is [[ =domain,:.],:.]])) => ans +-------> new <------------- + ans := compForm2([op',:argl],m,e:= addDomain(domain,e), + [x for x in getFormModemaps([op',:argl],e) | x is [[ =domain,:.],:.]]) => ans + (op'="construct") and coerceable(domain,m,e) => + (T:= comp([op',:argl],domain,e) or return nil; coerce(T,m)) + nil + + e:= addDomain(m,e) --???unneccessary because of comp2's call??? + (mmList:= getFormModemaps(form,e)) and (T:= compForm2(form,m,e,mmList)) => T + compToApply(op,argl,m,e) + +--% WI and MI + +compForm3(form is [op,:argl],m,e,modemapList) == +--order modemaps so that ones from Rep are moved to the front + modemapList := compFormOrderModemaps(modemapList,m = "$") + qe(22,e) + T:= + or/ + [compFormWithModemap(form,m,e,first (mml:= ml)) + for ml in tails modemapList] or return nil + qt(14,T) + result := + $compUniquelyIfTrue => + or/[compFormWithModemap(form,m,e,mm) for mm in rest mml] => + THROW("compUniquely",nil) + qt(15,T) + qt(16,T) + qt(17,markAny('compForm3,form,result)) + +compFormOrderModemaps(mml,targetIsDollar?) == +--order modemaps so that ones from Rep are moved to the front +--exceptions: if $ is the target and there are 2 modemaps with +-- identical signatures, move the $ one ahead + repMms := [mm for (mm:= [[dc,:.],:.]) in mml | dc = 'Rep] + if repMms and targetIsDollar? then + dollarMms := [mm for (mm := [[dc,:sig],:.]) in mml | dc = "$" + and or/[mm1 for (mm1:= [[dc1,:sig1],:.]) in repMms | sig1 = sig]] + repMms := [:dollarMms, :repMms] + null repMms => mml + [:repMms,:SETDIFFERENCE(mml,repMms)] + +compWI(["WI",a,b],m,E) == + u := comp(b,m,E) + pp (u => "====> ok"; 'NO) + u + +compMI(["MI",a,b],m,E) == + u := comp(b,m,E) + pp (u => "====> ok"; 'NO) + u + +compWhere([.,form,:exprList],m,eInit) == + $insideExpressionIfTrue: local:= false + $insideWhereIfTrue: local:= true +-- if not $insideFunctorIfTrue then +-- $originalTarget := +-- form is ['DEF,a,osig,:.] and osig is [otarget,:.] => +-- exprList is [['SEQ,:l,['exit,n,y]]] and (u := [:l,y]) and +-- (ntarget := or/[def for x in u | x is [op,a',:.,def] and ([op,a',otarget]) and +-- MEMQ(op,'(DEF MDEF)) and (a' = otarget or a' is [=otarget])]) => +-- [ntarget,:rest osig] +-- osig +-- nil +-- foobum exprList + e:= eInit + u:= + for item in exprList repeat + [.,.,e]:= comp(item,$EmptyMode,e) or return "failed" + u="failed" => return nil + $insideWhereIfTrue:= false + [x,m,eAfter]:= comp(macroExpand(form,eBefore:= e),m,e) or return nil + eFinal:= + del:= deltaContour(eAfter,eBefore) => addContour(del,eInit) + eInit + [x,m,eFinal] + +compMacro(form,m,e) == + $macroIfTrue: local:= true + ["MDEF",lhs,signature,specialCases,rhs]:= form := markKillAll form + firstForm := ["MDEF",first lhs,'(NIL),'(NIL),rhs] + markMacro(first lhs,rhs) + rhs := + rhs is ['CATEGORY,:.] => ['"-- the constructor category"] + rhs is ['Join,:.] => ['"-- the constructor category"] + rhs is ['CAPSULE,:.] => ['"-- the constructor capsule"] + rhs is ['add,:.] => ['"-- the constructor capsule"] + formatUnabbreviated rhs + sayBrightly ['" processing macro definition",'%b, + :formatUnabbreviated lhs,'" ==> ",:rhs,'%d] + ["MDEF",lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e) + m=$EmptyMode or m=$NoValueMode => + ["/throwAway",$NoValueMode,put(first lhs,"macro",rhs,e)] + +--compMacro(form,m,e) == +-- $macroIfTrue: local:= true +-- ["MDEF",lhs,signature,specialCases,rhs]:= form +-- rhs := +-- rhs is ['CATEGORY,:.] => ['"-- the constructor category"] +-- rhs is ['Join,:.] => ['"-- the constructor category"] +-- rhs is ['CAPSULE,:.] => ['"-- the constructor capsule"] +-- rhs is ['add,:.] => ['"-- the constructor capsule"] +-- formatUnabbreviated rhs +-- sayBrightly ['" processing macro definition",'%b, +-- :formatUnabbreviated lhs,'" ==> ",:rhs,'%d] +-- ["MDEF",lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e) +-- m=$EmptyMode or m=$NoValueMode => +-- rhs := markMacro(lhs,rhs) +-- ["/throwAway",$NoValueMode,put(first lhs,"macro",rhs,e)] + +compSetq(oform,m,E) == + ["LET",form,val] := oform + T := compSetq1(form,val,m,E) => markSetq(oform,T) + nil + +compSetq1(oform,val,m,E) == + form := markKillAll oform + IDENTP form => setqSingle(form,val,m,E) + form is [":",x,y] => + [.,.,E']:= compMakeDeclaration(form,$EmptyMode,E) + compSetq(["LET",x,val],m,E') + form is [op,:l] => + op="CONS" => setqMultiple(uncons form,val,m,E) + op="Tuple" => setqMultiple(l,val,m,E) + setqSetelt(oform,form,val,m,E) + +setqSetelt(oform,[v,:s],val,m,E) == + T:= comp0(["setelt",:oform,val],m,E) or return nil +---> ------- + markComp(oform,T) + +setqSingle(id,val,m,E) == + $insideSetqSingleIfTrue: local:= true + --used for comping domain forms within functions + currentProplist:= getProplist(id,E) + m'':= get(id,'mode,E) or getmode(id,E) or + (if m=$NoValueMode then $EmptyMode else m) +-----------------------> new <------------------------- + trialT := m'' = "$" and get("Rep",'value,E) and comp(val,'Rep,E) +-----------------------> new <------------------------- + T:= + (trialT and coerce(trialT,m'')) or eval or return nil where + eval() == + T:= comp(val,m'',E) => T + not get(id,"mode",E) and m'' ^= (maxm'':=maxSuperType(m'',E)) and + (T:=comp(val,maxm'',E)) => T + (T:= comp(val,$EmptyMode,E)) and getmode(T.mode,E) => + assignError(val,T.mode,id,m'') + T':= [x,m',e']:= convert(T,m) or return nil + if $profileCompiler = true then + null IDENTP id => nil + key := + MEMQ(id,rest $form) => 'arguments + 'locals + profileRecord(key,id,T.mode) + newProplist:= consProplistOf(id,currentProplist,"value",markKillAll removeEnv T) + e':= (PAIRP id => e'; addBinding(id,newProplist,e')) + x1 := markKillAll x + if isDomainForm(x1,e') then + if isDomainInScope(id,e') then + stackWarning ["domain valued variable","%b",id,"%d", + "has been reassigned within its scope"] + e':= augModemapsFromDomain1(id,x1,e') + --all we do now is to allocate a slot number for lhs + --e.g. the LET form below will be changed by putInLocalDomainReferences +--+ + if (k:=NRTassocIndex(id)) + then + $markFreeStack := [id,:$markFreeStack] + form:=['SETELT,"$",k,x] + else form:= + $QuickLet => ["LET",id,x] + ["LET",id,x, + (isDomainForm(x,e') => ['ELT,id,0];CAR outputComp(id,e'))] + [form,m',e'] + +setqMultiple(nameList,val,m,e) == + val is ["CONS",:.] and m=$NoValueMode => + setqMultipleExplicit(nameList,uncons val,m,e) + val is ["Tuple",:l] and m=$NoValueMode => setqMultipleExplicit(nameList,l,m,e) + --1. create a gensym, %add to local environment, compile and assign rhs + g:= genVariable() + e:= addBinding(g,nil,e) + T:= [.,m1,.]:= compSetq1(g,val,$EmptyMode,e) or return nil + e:= put(g,"mode",m1,e) + [x,m',e]:= convert(T,m) or return nil + --1.1 exit if result is a list + m1 is ["List",D] => + for y in nameList repeat e:= put(y,"value",[genSomeVariable(),D,$noEnv],e) + convert([["PROGN",x,["LET",nameList,g],g],m',e],m) + --2. verify that the #nameList = number of parts of right-hand-side + selectorModePairs:= + --list of modes + decompose(m1,#nameList,e) or return nil where + decompose(t,length,e) == + t is ["Record",:l] => [[name,:mode] for [":",name,mode] in l] + comp(t,$EmptyMode,e) is [.,["RecordCategory",:l],.] => + [[name,:mode] for [":",name,mode] in l] + stackMessage ["no multiple assigns to mode: ",t] + #nameList^=#selectorModePairs => + stackMessage [val," must decompose into ",#nameList," components"] + -- 3.generate code; return + assignList:= + [([.,.,e]:= compSetq1(x,["elt",g,y],z,e) or return "failed").expr + for x in nameList for [y,:z] in selectorModePairs] + if assignList="failed" then NIL + else [MKPROGN [x,:assignList,g],m',e] + +setqMultipleExplicit(nameList,valList,m,e) == + #nameList^=#valList => + stackMessage ["Multiple assignment error; # of items in: ",nameList, + "must = # in: ",valList] + gensymList:= [genVariable() for name in nameList] + for g in gensymList for name in nameList repeat + e := put(g,"mode",get(name,"mode",e),e) + assignList:= + --should be fixed to declare genVar when possible + [[.,.,e]:= compSetq1(g,val,$EmptyMode,e) or return "failed" + for g in gensymList for val in valList for name in nameList] + assignList="failed" => nil + reAssignList:= + [[.,.,e]:= compSetq1(name,g,$EmptyMode,e) or return "failed" + for g in gensymList for name in nameList] + reAssignList="failed" => nil + T := [["PROGN",:[T.expr for T in assignList], + :[T.expr for T in reAssignList]], $NoValueMode, (LAST reAssignList).env] + markMultipleExplicit(nameList,valList,T) + +canReturn(expr,level,exitCount,ValueFlag) == --SPAD: exit and friends + atom expr => ValueFlag and level=exitCount + (op:= first expr)="QUOTE" => ValueFlag and level=exitCount + MEMQ(op,'(WI MI)) => canReturn(CADDR expr,level,count,ValueFlag) + op="TAGGEDexit" => + expr is [.,count,data] => canReturn(data.expr,level,count,count=level) + level=exitCount and not ValueFlag => nil + op="SEQ" => or/[canReturn(u,level+1,exitCount,false) for u in rest expr] + op="TAGGEDreturn" => nil + op="CATCH" => + [.,gs,data]:= expr + (findThrow(gs,data,level,exitCount,ValueFlag) => true) where + findThrow(gs,expr,level,exitCount,ValueFlag) == + atom expr => nil + expr is ["THROW", =gs,data] => true + --this is pessimistic, but I know of no more accurate idea + expr is ["SEQ",:l] => + or/[findThrow(gs,u,level+1,exitCount,ValueFlag) for u in l] + or/[findThrow(gs,u,level,exitCount,ValueFlag) for u in rest expr] + canReturn(data,level,exitCount,ValueFlag) + op = "COND" => + level = exitCount => + or/[canReturn(last u,level,exitCount,ValueFlag) for u in rest expr] + or/[or/[canReturn(u,level,exitCount,ValueFlag) for u in v] + for v in rest expr] + op="IF" => + expr is [.,a,b,c] + if not canReturn(a,0,0,true) and not (BOUNDP '$convert2NewCompiler and $convert2NewCompiler) then + SAY "IF statement can not cause consequents to be executed" + pp expr + canReturn(a,level,exitCount,nil) or canReturn(b,level,exitCount,ValueFlag) + or canReturn(c,level,exitCount,ValueFlag) + --now we have an ordinary form + atom op => and/[canReturn(u,level,exitCount,ValueFlag) for u in expr] + op is ["XLAM",args,bods] => + and/[canReturn(u,level,exitCount,ValueFlag) for u in expr] + systemErrorHere '"canReturn" --for the time being + +compList(l,m is ["List",mUnder],e) == + markImport m + markImport mUnder + null l => [NIL,m,e] + Tl:= [[.,mUnder,e]:= + comp(x,mUnder,e) or return "failed" for i in 1.. for x in l] + Tl="failed" => nil + T:= [["LIST",:[T.expr for T in Tl]],["List",mUnder],e] + +compVector(l,m is ["Vector",mUnder],e) == + markImport m + markImport mUnder + null l => [$EmptyVector,m,e] + Tl:= [[.,mUnder,e]:= comp(x,mUnder,e) or return "failed" for x in l] + Tl="failed" => nil + [["VECTOR",:[T.expr for T in Tl]],m,e] + +compColon([":",f,t],m,e) == + $insideExpressionIfTrue=true => compPretend(["pretend",f,t],m,e) + --if inside an expression, ":" means to convert to m "on faith" + f := markKillAll f + $lhsOfColon: local:= f + t:= + t := markKillAll t + atom t and (t':= ASSOC(t,getDomainsInScope e)) => t' + isDomainForm(t,e) and not $insideCategoryIfTrue => + (if not member(t,getDomainsInScope e) then e:= addDomain(t,e); t) + isDomainForm(t,e) or isCategoryForm(t,e) => t + t is ["Mapping",m',:r] => t + unknownTypeError t + t + if $insideCapsuleFunctionIfTrue then markDeclaredImport t + f is ["LISTOF",:l] => + (for x in l repeat T:= [.,.,e]:= compColon([":",x,t],m,e); T) + e:= + f is [op,:argl] and not (t is ["Mapping",:.]) => + --for MPOLY--replace parameters by formal arguments: RDJ 3/83 + newTarget:= EQSUBSTLIST(take(#argl,$FormalMapVariableList), + [(x is [":",a,m] => a; x) for x in argl],t) + signature:= + ["Mapping",newTarget,: + [(x is [":",a,m] => m; + getmode(x,e) or systemErrorHere '"compColonOld") for x in argl]] + put(op,"mode",signature,e) + put(f,"mode",t,e) + if not $bootStrapMode and $insideFunctorIfTrue and + makeCategoryForm(t,e) is [catform,e] then + e:= put(f,"value",[genSomeVariable(),t,$noEnv],e) + ["/throwAway",getmode(f,e),e] + +compConstruct(form,m,e) == (T := compConstruct1(form,m,e)) and markConstruct(form,T) + +compConstruct1(form is ["construct",:l],m,e) == + y:= modeIsAggregateOf("List",m,e) => + T:= compList(l,["List",CADR y],e) => convert(T,m) + y:= modeIsAggregateOf("Vector",m,e) => + T:= compVector(l,["Vector",CADR y],e) => convert(T,m) + T:= compForm(form,m,e) => T + for D in getDomainsInScope e repeat + (y:=modeIsAggregateOf("List",D,e)) and + (T:= compList(l,["List",CADR y],e)) and (T':= convert(T,m)) => + return T' + (y:=modeIsAggregateOf("Vector",D,e)) and + (T:= compVector(l,["Vector",CADR y],e)) and (T':= convert(T,m)) => + return T' + +compPretend(u := ["pretend",x,t],m,e) == + t := markKillAll t + m := markKillAll m + e:= addDomain(t,e) + T:= comp(x,t,e) or comp(x,$EmptyMode,e) or return nil + if T.mode=t then warningMessage:= ["pretend",t," -- should replace by @"] + T1:= [T.expr,t,T.env] + t = "$" and m = "Rep" => markPretend(T1,T1) -->! WATCH OUT: correct? !<-- + T':= coerce(T1,m) => + warningMessage => + stackWarning warningMessage + markCompColonInside("@",T') + markPretend(T1,T') + nil + +compAtSign(["@",x,m'],m,e) == + m' := markKillAll m' + m := markKillAll m + e:= addDomain(m',e) + T:= comp(x,m',e) or return nil + coerce(T,m) + +compColonInside(x,m,e,m') == + m' := markKillAll m' + e:= addDomain(m',e) + T:= comp(x,$EmptyMode,e) or return nil + if T.mode=m' then warningMessage:= [":",m'," -- should replace by ::"] + T:= [T.expr,m',T.env] + m := markKillAll m + T':= coerce(T,m) => + warningMessage => + stackWarning warningMessage + markCompColonInside("@",T') + stackWarning [":",m'," -- should replace by pretend"] + markCompColonInside("pretend",T') + nil + +resolve(min, mout) == + din := markKillAll min + dout := markKillAll mout + din=$NoValueMode or dout=$NoValueMode => $NoValueMode + dout=$EmptyMode => din + STRINGP din and dout = '(Symbol) => dout ------> hack 8/14/94 + STRINGP dout and din = '(Symbol) => din ------> hack 8/14/94 + din^=dout and (STRINGP din or STRINGP dout) => + modeEqual(dout,$String) => dout + modeEqual(din,$String) => nil + mkUnion(din,dout) + dout + +coerce(T,m) == + T := [T.expr,markKillAll T.mode,T.env] + m := markKillAll m + if not get(m, 'isLiteral,T.env) then markImport m + $InteractiveMode => + keyedSystemError("S2GE0016",['"coerce", + '"function coerce called from the interpreter."]) +--==================> changes <====================== +--The following line is inappropriate for our needs::: +--rplac(CADR T,substitute("$",$Rep,CADR T)) + T' := coerce0(T,m) => T' + T := [T.expr,fullSubstitute("$",$Representation,T.mode),T.env] +--==================> changes <====================== + coerce0(T,m) + +coerce0(T,m) == + T':= coerceEasy(T,m) => T' + T':= coerceSubset(T,m) => markCoerce(T,T','AUTOSUBSET) + T':= coerceHard(T,m) => markCoerce(T,T','AUTOHARD) + T':= coerceExtraHard(T,m) => T' + T.expr = "$fromCoerceable$" or isSomeDomainVariable m => nil + T' := coerceRep(T,m) => markCoerce(T,T','AUTOREP) + stackMessage fn(T.expr,T.mode,m) where + -- if from from coerceable, this coerce was just a trial coercion + -- from compFormWithModemap to filter through the modemaps + fn(x,m1,m2) == + ["Cannot coerce","%b",x,"%d","%l"," of mode","%b",m1,"%d","%l", + " to mode","%b",m2,"%d"] + +coerceSubset(T := [x,m,e],m') == + m = $SmallInteger => + m' = $Integer => [x,m',e] + m' = (r := get(x,'range,e)) or isSubset(r,m',e) => [x,r,e] + nil +-- pp [m, m'] + isSubset(m,m',e) or m="Rep" and m'="$" => [x,m',e] + m is ['SubDomain,=m',:.] => [x,m',e] + (pred:= LASSOC(opOf m',get(opOf m,'SubDomain,e))) and INTEGERP x and + -- obviously this is temporary + eval substitute(x,"#1",pred) => [x,m',e] + (pred:= isSubset(m',maxSuperType(m,e),e)) and INTEGERP x -- again temporary + and eval substitute(x,"*",pred) => + [x,m',e] + nil + +coerceRep(T,m) == + md := T.mode + atom md => nil + CONTAINED('Rep,md) and SUBST('$,'Rep,md) = m or + CONTAINED('Rep,m) and SUBST('$,'Rep,m) = md => T + nil + +--- GET rid of XLAMs +spadCompileOrSetq form == + --bizarre hack to take account of the existence of "known" functions + --good for performance (LISPLLIB size, BPI size, NILSEC) + [nam,[lam,vl,body]] := form + CONTAINED(" ",body) => sayBrightly ['" ",:bright nam,'" not compiled"] + if vl is [:vl',E] and body is [nam',: =vl'] then + LAM_,EVALANDFILEACTQ ['PUT,MKQ nam,MKQ 'SPADreplace,MKQ nam'] + sayBrightly ['" ",:bright nam,'"is replaced by",:bright nam'] + else if (ATOM body or and/[ATOM x for x in body]) + and vl is [:vl',E] and not CONTAINED(E,body) then + macform := ['XLAM,vl',body] + LAM_,EVALANDFILEACTQ ['PUT,MKQ nam,MKQ 'SPADreplace,MKQ macform] + sayBrightly ['" ",:bright nam,'"is replaced by",:bright body] + $insideCapsuleFunctionIfTrue => first COMP LIST form + compileConstructor form + +coerceHard(T,m) == + $e: local:= T.env + m':= T.mode + STRINGP m' and modeEqual(m,$String) => [T.expr,m,$e] + modeEqual(m',m) or + (get(m',"value",$e) is [m'',:.] or getmode(m',$e) is ["Mapping",m'']) and + modeEqual(m'',m) or + (get(m,"value",$e) is [m'',:.] or getmode(m,$e) is ["Mapping",m'']) and + modeEqual(m'',m') => [T.expr,m,T.env] + STRINGP T.expr and T.expr=m => [T.expr,m,$e] + isCategoryForm(m,$e) => + $bootStrapMode = true => [T.expr,m,$e] + extendsCategoryForm(T.expr,T.mode,m) => [T.expr,m,$e] + nil + nil + +coerceExtraHard(T is [x,m',e],m) == + T':= autoCoerceByModemap(T,m) => T' + isUnionMode(m',e) is ["Union",:l] and (t:= hasType(x,e)) and + member(t,l) and (T':= autoCoerceByModemap(T,t)) and + (T'':= coerce(T',m)) => T'' + m' is ['Record,:.] and m = $Expression => + [['coerceRe2E,x,['ELT,COPY m',0]],m,e] + nil + +compCoerce(u := ["::",x,m'],m,e) == + m' := markKillAll m' + e:= addDomain(m',e) + m := markKillAll m +--------------> new code <------------------- + T:= compCoerce1(x,m',e) => coerce(T,m) + T := comp(x,$EmptyMode,e) or return nil + T.mode = $SmallInteger and + MEMQ(opOf m,'(NonNegativeInteger PositiveInteger)) => + compCoerce(["::",["::",x,$Integer],m'],m,e) +--------------> new code <------------------- + getmode(m',e) is ["Mapping",["UnionCategory",:l]] => + l := [markKillAll x for x in l] + T:= (or/[compCoerce1(x,m1,e) for m1 in l]) or return nil + coerce([T.expr,m',T.env],m) + +compCoerce1(x,m',e) == + T:= comp(x,m',e) + if null T then T := comp(x,$EmptyMode,e) + null T => return nil + m1:= + STRINGP T.mode => $String + T.mode + m':=resolve(m1,m') + T:=[T.expr,m1,T.env] + T':= coerce(T,m') => T' + T':= coerceByModemap(T,m') => T' + pred:=isSubset(m',T.mode,e) => + gg:=GENSYM() + pred:= substitute(gg,"*",pred) + code:= ['PROG1,['LET,gg,T.expr], ['check_-subtype,pred,MKQ m',gg]] + [code,m',T.env] + +coerceByModemap([x,m,e],m') == +--+ modified 6/27 for new runtime system + u:= + [modemap + for (modemap:= [map,cexpr]) in getModemapList("coerce",1,e) | map is [.,t, + s] and (modeEqual(t,m') or isSubset(t,m',e)) + and (modeEqual(s,m) or isSubset(m,s,e))] or return nil + mm:=first u -- patch for non-trival conditons + fn := genDeltaEntry ['coerce,:mm] + T := [["call",fn,x],m',e] + markCoerceByModemap(x,m,m',markCallCoerce(x,m',T),nil) + +autoCoerceByModemap([x,source,e],target) == + u:= + [cexpr + for (modemap:= [map,cexpr]) in getModemapList("autoCoerce",1,e) | map is [ + .,t,s] and modeEqual(t,target) and modeEqual(s,source)] or return nil + fn:= (or/[selfn for [cond,selfn] in u | cond=true]) or return nil + markCoerceByModemap(x,source,target,[["call",fn,x],target,e],true) + +--====================================================================== +-- From compiler.boot +--====================================================================== +--comp3x(x,m,$e) == + +comp3(x,m,$e) == + --returns a Triple or %else nil to signalcan't do' + $e:= addDomain(m,$e) + e:= $e --for debugging purposes + m is ["Mapping",:.] => compWithMappingMode(x,m,e) + m is ["QUOTE",a] => (x=a => [x,m,$e]; nil) + STRINGP m => (atom x => (m=x or m=STRINGIMAGE x => [m,m,e]; nil); nil) + ^x or atom x => compAtom(x,m,e) + op:= first x + getmode(op,e) is ["Mapping",:ml] and (u:= applyMapping(x,m,e,ml)) => u + op is ["KAPPA",sig,varlist,body] => compApply(sig,varlist,body,rest x,m,e) + op=":" => compColon(x,m,e) + op="::" => compCoerce(x,m,e) + not ($insideCompTypeOf=true) and stringPrefix?('"TypeOf",PNAME op) => + compTypeOf(x,m,e) + ------------special jump out code for PART (don't want $insideExpressionIfTrue=true)-- + x is ['PART,:.] => compPART(x,m,e) + ---------------------------------- + t:= qt(14,compExpression(x,m,e)) + t is [x',m',e'] and not member(m',getDomainsInScope e') => + qt(15,[x',m',addDomain(m',e')]) + qt(16,t) + +yyyyy x == x +compExpression(x,m,e) == + $insideExpressionIfTrue: local:= true + if x is ['LET,['PART,.,w],[['elt,B,'new],['PART,.,["#",['PART,.,l]]],:.],:.] then yyyyy x + x := compRenameOp x + atom first x and (fn:= GETL(first x,"SPECIAL")) => + FUNCALL(fn,x,m,e) + compForm(x,m,e) + +compRenameOp x == ----------> new 12/3/94 + x is [op,:r] and op is ['PART,.,op1] => + [op1,:r] + x + +compCase(["case",x,m1],m,e) == + m' := markKillAll m1 + e:= addDomain(m',e) + T:= compCase1(x,m',e) => coerce(T,m) + nil + +compCase1(x,m,e) == + x1 := + x is ['PART,.,a] => a + x + [x',m',e']:= comp(x1,$EmptyMode,e) or return nil + if m' = "$" then (m' := IFCAR get('Rep,'value,e)) and (switchMode := true) + -------------------------------------------------------------------------- + m' isnt ['Union,:r] => nil + mml := [mm for (mm := [map,cexpr]) in getModemapList("case",2,e') + | map is [.,.,s,t] and modeEqual(t,m) and + (modeEqual(s,m') or switchMode and modeEqual(s,"$"))] + or return nil + u := [cexpr for [.,cexpr] in mml] + fn:= (or/[selfn for [cond,selfn] in u | cond=true]) or return nil + tag := genCaseTag(m, r, 1) or return nil + x1 := + switchMode => markRepper('rep, x) + x + markCase(x, tag, markCaseWas(x1,[["call",fn,x'],$Boolean,e'])) + +genCaseTag(t,l,n) == + l is [x, :l] => + x = t => + STRINGP x => INTERN x + INTERN STRCONC("value", STRINGIMAGE n) + x is ["::",=t,:.] => t + STRINGP x => genCaseTag(t, l, n) + genCaseTag(t, l, n + 1) + nil + +compIf(["IF",aOrig,b,c],m,E) == + a := markKillButIfs aOrig + [xa,ma,Ea,Einv]:= compBoolean(a,aOrig,$Boolean,E) or return nil + [xb,mb,Eb]:= Tb:= compFromIf(b,m,Ea) or return nil + [xc,mc,Ec]:= Tc:= compFromIf(c,resolve(mb,m),Einv) or return nil + xb':= coerce(Tb,mc) or return nil + x:= ["IF",xa,quotify xb'.expr,quotify xc] + (returnEnv:= Env(xb'.env,Ec,xb'.expr,xc,E)) where + Env(bEnv,cEnv,b,c,E) == + canReturn(b,0,0,true) => + (canReturn(c,0,0,true) => intersectionEnvironment(bEnv,cEnv); bEnv) + canReturn(c,0,0,true) => cEnv + E + [x,mc,returnEnv] + +compBoolean(p,pWas,m,Einit) == + op := opOf p + [p',m,E]:= + fop := LASSOC(op,'((and . compAnd) (or . compOr) (not . compNot))) => + APPLY(fop,[p,pWas,m,Einit]) or return nil + T := comp(p,m,Einit) or return nil + markAny('compBoolean,pWas,T) + [p',m,getSuccessEnvironment(markKillAll p,E), + getInverseEnvironment(markKillAll p,E)] + +compAnd([op,:args], pWas, m, e) == +--called ONLY from compBoolean + cargs := [T.expr for x in args + | [.,.,e,.] := T := compBoolean(x,x,$Boolean,e) or return nil] + null cargs => nil + coerce(markAny('compAnd,pWas,[["AND",:cargs],$Boolean,e]),m) + +compOr([op,:args], pWas, m, e) == +--called ONLY from compBoolean + cargs := [T.expr for x in args + | [.,.,.,e] := T := compBoolean(x,x,$Boolean,e) or return nil] + null cargs => nil + coerce(markAny('compOr,pWas, [["OR",:cargs],$Boolean,e]),m) + +compNot([op,arg], pWas, m, e) == +--called ONLY from compBoolean + [x,m1,.,ei] := compBoolean(arg,arg,$Boolean,e) or return nil + coerce(markAny('compNot, pWas, [["NOT",x],$Boolean,ei]),m) + +compDefine(form,m,e) == + $tripleHits: local:= 0 + $macroIfTrue: local + $packagesUsed: local + ['DEF,.,originalSignature,.,body] := form + if not $insideFunctorIfTrue then + $originalBody := COPY body + compDefine1(form,m,e) + +compDefine1(form,m,e) == + $insideExpressionIfTrue: local:= false + --1. decompose after macro-expanding form + ['DEF,lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e) + $insideWhereIfTrue and isMacro(form,e) and (m=$EmptyMode or m=$NoValueMode) + => [lhs,m,put(first lhs,'macro,rhs,e)] + null signature.target and not MEMQ(KAR rhs,$ConstructorNames) and + (sig:= getSignatureFromMode(lhs,e)) => + -- here signature of lhs is determined by a previous declaration + compDefine1(['DEF,lhs,[first sig,:rest signature],specialCases,rhs],m,e) + if signature.target=$Category then $insideCategoryIfTrue:= true + if signature.target is ['Mapping,:map] then + signature:= map + form:= ['DEF,lhs,signature,specialCases,rhs] + + +-- RDJ (11/83): when argument and return types are all declared, +-- or arguments have types declared in the environment, +-- and there is no existing modemap for this signature, add +-- the modemap by a declaration, then strip off declarations and recurse + e := compDefineAddSignature(lhs,signature,e) +-- 2. if signature list for arguments is not empty, replace ('DEF,..) by +-- ('where,('DEF,..),..) with an empty signature list; +-- otherwise, fill in all NILs in the signature + not (and/[null x for x in rest signature]) => compDefWhereClause(form,m,e) + signature.target=$Category => + compDefineCategory(form,m,e,nil,$formalArgList) + isDomainForm(rhs,e) and not $insideFunctorIfTrue => + if null signature.target then signature:= + [getTargetFromRhs(lhs,rhs,giveFormalParametersValues(rest lhs,e)),: + rest signature] + rhs:= addEmptyCapsuleIfNecessary(signature.target,rhs) + compDefineFunctor(['DEF,lhs,signature,specialCases,rhs],m,e,nil, + $formalArgList) + null $form => stackAndThrow ['"bad == form ",form] + newPrefix:= + $prefix => INTERN STRCONC(encodeItem $prefix,'",",encodeItem $op) + getAbbreviation($op,#rest $form) + compDefineCapsuleFunction(form,m,e,newPrefix,$formalArgList) + +compDefineCategory(df,m,e,prefix,fal) == + $domainShell: local -- holds the category of the object being compiled + $lisplibCategory: local + not $insideFunctorIfTrue and $LISPLIB => + compDefineLisplib(df,m,e,prefix,fal,'compDefineCategory1) + compDefineCategory1(df,m,e,prefix,fal) + +compDefineCategory1(df,m,e,prefix,fal) == + $DEFdepth : local := 0 --for conversion to new compiler 3/93 + $capsuleStack : local := nil --for conversion to new compiler 3/93 + $predicateStack:local := nil --for conversion to new compiler 3/93 + $signatureStack:local := nil --for conversion to new compiler 3/93 + $importStack : local := nil --for conversion to new compiler 3/93 + $globalImportStack : local := nil --for conversion to new compiler 3/93 + $catAddForm : local := nil --for conversion to new compiler 2/95 + $globalDeclareStack : local := nil + $globalImportDefAlist: local:= nil + $localMacroStack : local := nil --for conversion to new compiler 3/93 + $freeStack : local := nil --for conversion to new compiler 3/93 + $domainLevelVariableList: local := nil--for conversion to new compiler 3/93 + $categoryTranForm : local := nil --for conversion to new compiler 10/93 + ['DEF,form,sig,sc,body] := df + body := markKillAll body --these parts will be replaced by compDefineLisplib + categoryCapsule := +--+ + body is ['add,cat,capsule] => + body := cat + capsule + nil + [d,m,e]:= compDefineCategory2(form,sig,sc,body,m,e,prefix,fal) +--+ next two lines +-- if BOUNDP '$convertingSpadFile and $convertingSpadFile then nil +-- else + if categoryCapsule and not $bootStrapMode then + [.,.,e] := + $insideCategoryPackageIfTrue: local := true --see NRTmakeSlot1 + $categoryPredicateList: local := + makeCategoryPredicates(form,$lisplibCategory) + defform := mkCategoryPackage(form,cat,categoryCapsule) + ['DEF,[.,arg,:.],:.] := defform + $categoryNameForDollar :local := arg + compDefine1(defform,$EmptyMode,e) + else + [body,T] := $categoryTranForm + markFinish(body,T) + + [d,m,e] + +compDefineCategory2(form,signature,specialCases,body,m,e, + $prefix,$formalArgList) == + --1. bind global variables + $insideCategoryIfTrue: local:= true + $TOP__LEVEL: local + $definition: local + --used by DomainSubstitutionFunction + $form: local + $op: local + $extraParms: local + --Set in DomainSubstitutionFunction, used further down +-- 1.1 augment e to add declaration $:
+ [$op,:argl]:= $definition:= form + e:= addBinding("$",[['mode,:$definition]],e) + +-- 2. obtain signature + signature':= + [first signature,:[getArgumentModeOrMoan(a,$definition,e) for a in argl]] + e:= giveFormalParametersValues(argl,e) + +-- 3. replace arguments by $1,..., substitute into body, +-- and introduce declarations into environment + sargl:= TAKE(# argl, $TriangleVariableList) + $functorForm:= $form:= [$op,:sargl] + $formalArgList:= [:sargl,:$formalArgList] + aList:= [[a,:sa] for a in argl for sa in sargl] + formalBody:= SUBLIS(aList,body) + signature' := SUBLIS(aList,signature') +--Begin lines for category default definitions + $functionStats: local:= [0,0] + $functorStats: local:= [0,0] + $frontier: local := 0 + $getDomainCode: local := nil + $addForm: local:= nil + for x in sargl for t in rest signature' repeat + [.,.,e]:= compMakeDeclaration([":",x,t],m,e) + +-- 4. compile body in environment of %type declarations for arguments + op':= $op + -- following line causes cats with no with or Join to be fresh copies + if opOf(formalBody)^='Join and opOf(formalBody)^='mkCategory then + formalBody := ['Join, formalBody] + T := compOrCroak(formalBody,signature'.target,e) +--------------------> new <------------------- + $catAddForm := + $originalBody is ['add,y,:.] => y + $originalBody + $categoryTranForm := [$originalBody,[$form,['Mapping,:signature'],T.env]] +--------------------> new <------------------- + body:= optFunctorBody markKillAll T.expr + if $extraParms then + formals:=actuals:=nil + for u in $extraParms repeat + formals:=[CAR u,:formals] + actuals:=[MKQ CDR u,:actuals] + body := ['sublisV,['PAIR,['QUOTE,formals],['LIST,:actuals]],body] + if argl then body:= -- always subst for args after extraparms + ['sublisV,['PAIR,['QUOTE,sargl],['LIST,: + [['devaluate,u] for u in sargl]]],body] + body:= + ['PROG1,['LET,g:= GENSYM(),body],['SETELT,g,0,mkConstructor $functorForm]] + fun:= compile [op',['LAM,sargl,body]] + +-- 5. give operator a 'modemap property + pairlis:= [[a,:v] for a in argl for v in $FormalMapVariableList] + parSignature:= SUBLIS(pairlis,signature') + parForm:= SUBLIS(pairlis,form) +---- lisplibWrite('"compilerInfo", +---- ['SETQ,'$CategoryFrame, +---- ['put,['QUOTE,op'],' +---- (QUOTE isCategory),true,['addModemap,MKQ op',MKQ parForm, +---- MKQ parSignature,true,MKQ fun,'$CategoryFrame]]],$libFile) + --Equivalent to the following two lines, we hope + if null sargl then + evalAndRwriteLispForm('NILADIC, + ['MAKEPROP,['QUOTE,op'],'(QUOTE NILADIC),true]) + +-- 6. put modemaps into InteractiveModemapFrame + $domainShell := + BOUNDP '$convertingSpadFile and $convertingSpadFile => nil + eval [op',:MAPCAR('MKQ,sargl)] + $lisplibCategory:= formalBody +---- if $LISPLIB then +---- $lisplibForm:= form +---- $lisplibKind:= 'category +---- modemap:= [[parForm,:parSignature],[true,op']] +---- $lisplibModemap:= modemap +---- $lisplibCategory:= formalBody +---- form':=[op',:sargl] +---- augLisplibModemapsFromCategory(form',formalBody,signature') + [fun,'(Category),e] diff --git a/src/interp/wi1.boot.pamphlet b/src/interp/wi1.boot.pamphlet deleted file mode 100644 index a86a7da2..00000000 --- a/src/interp/wi1.boot.pamphlet +++ /dev/null @@ -1,1287 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/wi1.boot} Pamphlet} -\author{The Axiom Team} - -\begin{document} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\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" - --- !! do not delete the next function ! - -spad2AsTranslatorAutoloadOnceTrigger() == nil - -pairList(u,v) == [[x,:y] for x in u for y in v] - ---====================================================================== --- Temporary definitions---for tracing and debugging ---====================================================================== -tr fn == - $convertingSpadFile : local := true - $options: local := nil - sfn := STRINGIMAGE fn - newname := STRCONC(sfn,'".as") - $outStream :local := MAKE_-OUTSTREAM newname - markSay '"#pile" - markSay('"#include _"axiom.as_"") - markTerpri() - CATCH("SPAD__READER",compiler [INTERN sfn]) - SHUT $outStream - -stackMessage msg == ---if msg isnt ["cannot coerce: ",:.] then foobum msg - $compErrorMessageStack:= [msg,:$compErrorMessageStack] - nil - -ppFull x == - _*PRINT_-LEVEL_* : local := nil - _*PRINT_-DEPTH_* : local := nil - _*PRINT_-LENGTH_* : local := nil - pp x - -put(x,prop,val,e) == ---if prop = 'mode and CONTAINED('PART,val) then foobar val - $InteractiveMode and not EQ(e,$CategoryFrame) => - putIntSymTab(x,prop,val,e) - --e must never be $CapsuleModemapFrame - null atom x => put(first x,prop,val,e) - newProplist:= augProplistOf(x,prop,val,e) - prop="modemap" and $insideCapsuleFunctionIfTrue=true => - SAY ["**** modemap PUT on CapsuleModemapFrame: ",val] - $CapsuleModemapFrame:= - addBinding(x,augProplistOf(x,"modemap",val,$CapsuleModemapFrame), - $CapsuleModemapFrame) - e - addBinding(x,newProplist,e) - -addBinding(var,proplist,e is [[curContour,:tailContour],:tailEnv]) == ---if CONTAINED('PART,proplist) then foobar proplist - 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] - ---====================================================================== --- From define.boot ---====================================================================== -compJoin(["Join",:argl],m,e) == - catList:= [(compForMode(x,$Category,e) or return 'failed).expr for x in argl] - catList='failed => stackSemanticError(["cannot form Join of: ",argl],nil) - catList':= - [extract for x in catList] where - extract() == - x := markKillAll x - isCategoryForm(x,e) => - parameters:= - union("append"/[getParms(y,e) for y in rest x],parameters) - where getParms(y,e) == - atom y => - isDomainForm(y,e) => LIST y - nil - y is ['LENGTH,y'] => [y,y'] - LIST y - x - x is ["DomainSubstitutionMacro",pl,body] => - (parameters:= union(pl,parameters); body) - x is ["mkCategory",:.] => x - atom x and getmode(x,e)=$Category => x - stackSemanticError(["invalid argument to Join: ",x],nil) - x - T:= [wrapDomainSub(parameters,["Join",:catList']),$Category,e] - convert(T,m) - - -compDefineFunctor(dfOriginal,m,e,prefix,fal) == - df := markInsertParts dfOriginal - $domainShell: local -- holds the category of the object being compiled - $profileCompiler: local := true - $profileAlist: local := nil - $LISPLIB => compDefineLisplib(df,m,e,prefix,fal,'compDefineFunctor1) - compDefineFunctor1(df,m,e,prefix,fal) - -compDefineLisplib(df,m,e,prefix,fal,fn) == - ["DEF",[op,:.],:.] := df - --fn= compDefineCategory OR compDefineFunctor - sayMSG fillerSpaces(72,'"-") - $LISPLIB: local := 'T - $op: local := op - $lisplibAttributes: local := NIL - $lisplibPredicates: local := NIL -- set by makePredicateBitVector - $lisplibCategoriesExtended: local := NIL -- this is always nil. why? (tpd) - $lisplibForm: local := NIL - $lisplibKind: local := NIL - $lisplibModemap: local := NIL - $lisplibModemapAlist: local := NIL - $lisplibSlot1 : local := NIL -- used by NRT mechanisms - $lisplibOperationAlist: local := NIL - $lisplibSuperDomain: local := NIL - $libFile: local := NIL - $lisplibVariableAlist: local := NIL - $lisplibRelatedDomains: local := NIL --from ++ Related Domains: see c-doc - $lisplibCategory: local := nil - --for categories, is rhs of definition; otherwise, is target of functor - --will eventually become the "constructorCategory" property in lisplib - --set in compDefineCategory if category, otherwise in finalizeLisplib - libName := getConstructorAbbreviation op - -- $incrementalLisplibFlag seems never to be set so next line not used - -- originalLisplibCategory:= getLisplib(libName,'constructorCategory) - BOUNDP '$compileDocumentation and $compileDocumentation => - compileDocumentation libName - sayMSG ['" initializing ",$spadLibFT,:bright libName, - '"for",:bright op] - initializeLisplib libName - sayMSG ['" compiling into ",$spadLibFT,:bright libName] - res:= FUNCALL(fn,df,m,e,prefix,fal) - sayMSG ['" finalizing ",$spadLibFT,:bright libName] ---finalizeLisplib libName - FRESH_-LINE $algebraOutputStream - sayMSG fillerSpaces(72,'"-") - unloadOneConstructor(op,libName) - res - -compTopLevel(x,m,e) == ---+ signals that target is derived from lhs-- see NRTmakeSlot1Info - $NRTderivedTargetIfTrue: local := false - $killOptimizeIfTrue: local:= false - $forceAdd: local:= false - $compTimeSum: local := 0 - $resolveTimeSum: local := 0 - $packagesUsed: local := [] - -- The next line allows the new compiler to be tested interactively. - compFun := if $newCompAtTopLevel=true then 'newComp else 'compOrCroak - if x is ["where",:.] then x := markWhereTran x - def := - x is ["where",a,:.] => a - x - $originalTarget : local := - def is ["DEF",.,[target,:.],:.] => target - 'sorry - x is ["DEF",:.] or x is ["where",["DEF",:.],:.] => - ([val,mode,.]:= FUNCALL(compFun,x,m,e); [val,mode,e]) - --keep old environment after top level function defs - FUNCALL(compFun,x,m,e) - -markWhereTran ["where",["DEF",form,sig,clist,body],:tail] == - items := - tail is [['SEQ,:l,['exit,n,x]]] => [:l,x] - [first tail] - [op,:argl] := form - [target,:atypeList] := sig - decls := [[":",a,b] for a in argl for b in atypeList | b] --- not (and/[null x for x in atypeList]) => --- systemError ['"unexpected WHERE argument list: ",:atypeList] - for x in items repeat - x is [":",a,b] => - a is ['LISTOF,:r] => - for y in r repeat decls := [[":",y,b],:decls] - decls := [x,:decls] - x is [key,fn,p,q,bd] and MEMQ(key,'(DEF MDEF)) and p='(NIL) and q='(NIL) => - fn = target or fn is [=target] => ttype := bd - fn = body or fn is [=body] => body := bd - macros := [x,:macros] - systemError ['"unexpected WHERE item: ",x] - nargtypes := [p for arg in argl | - p := or/[t for d in decls | d is [.,=arg,t]] or - systemError ['"Missing WHERE declaration for :", arg]] - nform := form - ntarget := ttype or target - ndef := ['DEF,nform,[ntarget,:nargtypes],clist,body] - result := - REVERSE macros is [:m,e] => - mpart := - m => ['SEQ,:m,['exit,1,e]] - e - ['where,ndef,mpart] - ndef - result - -compPART(u,m,e) == ---------new------------------------------------------94/10/11 - ['PART,.,x] := u - T := comp(x,m,e) => markAny('compPART,u, T) - nil - -xxxxx x == x - -qt(n,T) == - null T => nil - if null getProplist('R,T.env) then xxxxx n - T - -qe(n,e) == - if null getProplist('R,e) then xxxxx n - e - -comp(x,m,e) == - qe(7,e) - T := qt(8,comp0(x,m,e)) => qt(9,markComp(x,T)) ---T := m = "$" and comp(x,$EmptyMode,e) => coerce(T, m) - --------------------------------------------------------94/11/10 - nil - -comp0(x,m,e) == - qe(8,e) ---version of comp which skips the marking (see compReduce1) - T:= compNoStacking(x,m,e) => - $compStack:= nil - qt(10,T) - $compStack:= [[x,m,e,$exitModeStack],:$compStack] - nil - -compNoStacking(xOrig,m,e) == - $partExpression: local := nil - xOrig := markKillAllRecursive xOrig --->xOrig is ['PART,n,x] => compNoStackingAux(xOrig,m,e) -----------------------------------------------------------94/10/11 - qt(11,compNoStacking0(xOrig,m,e)) - -markKillAllRecursive x == - x is [op,:r] => ---->op = 'PART => markKillAllRecursive CADR r - op = 'PART => ['PART, CAR r, markKillAllRecursive CADR r] -----------------------------------------------------------94/10/11 - constructor? op => markKillAll x - op = 'elt and constructor? opOf CAR r => - ['elt,markKillAllRecursive CAR r,CADR r] - x - x - -compNoStackingAux($partExpression,m,e) == ------------------not used---------------------94/10/11 - x := CADDR $partExpression - T := compNoStacking0(x,m,e) or return nil - markParts($partExpression,T) - -compNoStacking0(x,m,e) == - qe(1,e) - T := compNoStacking01(x,m,qe(51,e)) - qt(52,T) - -compNoStacking01(x,m,e) == ---compNoStacking0(x,m,e) == - if CONTAINED('MI,m) then m := markKillAll(m) - T:= comp2(x,m,e) => - (m=$EmptyMode and T.mode=IFCAR(get('Rep,'value,e)) => - [T.expr,"Rep",T.env]; qt(12,T)) - --$Representation is bound in compDefineFunctor, set by doIt - --this hack says that when something is undeclared, $ is - --preferred to the underlying representation -- RDJ 9/12/83 - T := compNoStacking1(x,m,e,$compStack) - qt(13,T) - -compNoStacking1(x,m,e,$compStack) == - u:= get(if m="$" then "Rep" else m,"value",e) => - m1 := markKillAll u.expr ---------------------> new <------------------------- - T:= comp2(x,m1,e) => coerce(T,m) - nil ---------------------> new <------------------------- - nil - -compWithMappingMode(x,m,oldE) == - ["Mapping",m',:sl] := m - $killOptimizeIfTrue: local:= true - e:= oldE - x := markKillAll x - ------------------ - m := markKillAll m - ------------------ ---if x is ['PART,.,y] then x := y ---------------------------------- - isFunctor x => - if get(x,"modemap",$CategoryFrame) is [[[.,target,:argModeList],.],:.] and - (and/[extendsCategoryForm("$",s,mode) for mode in argModeList for s in sl] - ) and extendsCategoryForm("$",target,m') then return [x,m,e] - if STRINGP x then x:= INTERN x - for m in sl for v in (vl:= take(#sl,$FormalMapVariableList)) repeat - [.,.,e]:= compMakeDeclaration([":",v,m],$EmptyMode,e) - not null vl and not hasFormalMapVariable(x, vl) => return - [u,.,.] := comp([x,:vl],m',e) or return nil - extractCodeAndConstructTriple(u, m, oldE) - null vl and (t := comp([x], m', e)) => return - [u,.,.] := t - extractCodeAndConstructTriple(u, m, oldE) - [u,.,.]:= comp(x,m',e) or return nil - originalFun := u - if originalFun is ['WI,a,b] then u := b - uu := ['LAMBDA,vl,u] - --------------------------> 11/28 drop COMP-TRAN, optimizations - T := [uu,m,oldE] - originalFun is ['WI,a,b] => markLambda(vl,a,m,T) - markLambda(vl,originalFun,m,T) - -compAtom(x,m,e) == - T:= compAtomWithModemap(x,m,e,get(x,"modemap",e)) => markCompAtom(x,T) - x="nil" => - T:= - modeIsAggregateOf('List,m,e) is [.,R]=> compList(x,['List,R],e) - modeIsAggregateOf('Vector,m,e) is [.,R]=> compVector(x,['Vector,R],e) - T => convert(T,m) ---> - FIXP x and MEMQ(opOf m, '(Integer NonNegativeInteger PositiveInteger SmallInteger)) => markAt [x,m,e] --- FIXP x and (T := [x, $Integer,e]) and (T' := convert(T,m)) => markAt(T, T') - t:= - isSymbol x => - compSymbol(x,m,e) or return nil - m = $Expression and primitiveType x => [x,m,e] - STRINGP x => - x ^= '"failed" and (member('(Symbol), $localImportStack) or - member('(Symbol), $globalImportStack)) => markAt [x, '(String), e] - [x, x, e] - [x,primitiveType x or return nil,e] - convert(t,m) - -extractCodeAndConstructTriple(u, m, oldE) == - u := markKillAll u - u is ["call",fn,:.] => - if fn is ["applyFun",a] then fn := a - [fn,m,oldE] - [op,:.,env] := u - [["CONS",["function",op],env],m,oldE] - -compSymbol(s,m,e) == - s="$NoValue" => ["$NoValue",$NoValueMode,e] - isFluid s => [s,getmode(s,e) or return nil,e] - s="true" => ['(QUOTE T),$Boolean,e] - s="false" => [false,$Boolean,e] - s=m or get(s,"isLiteral",e) => [["QUOTE",s],s,e] - v:= get(s,"value",e) => ---+ - MEMQ(s,$functorLocalParameters) => - NRTgetLocalIndex s - [s,v.mode,e] --s will be replaced by an ELT form in beforeCompile - [s,v.mode,e] --s has been SETQd - m':= getmode(s,e) => - if not member(s,$formalArgList) and not MEMQ(s,$FormalMapVariableList) and - not isFunction(s,e) and null ($compForModeIfTrue=true) then errorRef s - [s,m',e] --s is a declared argument - MEMQ(s,$FormalMapVariableList) => stackMessage ["no mode found for",s] ----> - m = $Symbol or m = $Expression => [['QUOTE,s],m,e] - ---> was ['QUOTE, s] - not isFunction(s,e) => errorRef s - -compForm(form,m,e) == - if form is [['PART,.,op],:r] then form := [op,:r] - ----------------------------------------------------- 94/10/16 - T:= - compForm1(form,m,e) or compArgumentsAndTryAgain(form,m,e) or return - stackMessageIfNone ["cannot compile","%b",form,"%d"] - T - -compForm1(form,m,e) == - [op,:argl] := form - $NumberOfArgsIfInteger: local:= #argl --see compElt - op="error" => - [[op,:[([.,.,e]:=outputComp(x,e)).expr - for x in argl]],m,e] - op is ['MI,a,b] => compForm1([markKillExpr b,:argl],m,e) - op is ["elt",domain,op'] => - domain := markKillAll domain - domain="Lisp" => - --op'='QUOTE and null rest argl => [first argl,m,e] - val := [op',:[([.,.,e]:= compOrCroak(x,$EmptyMode,e)).expr for x in argl]] - markLisp([val,m,e],m) --------> new <------------- --- foobar domain --- markImport(domain,true) --------> new <------------- - domain=$Expression and op'="construct" => compExpressionList(argl,m,e) - (op'="COLLECT") and coerceable(domain,m,e) => - (T:= comp([op',:argl],domain,e) or return nil; coerce(T,m)) --------> new <------------- - domain= 'Rep and - (ans := compForm2([op',:argl],SUBST('Rep,'_$,m),e:= addDomain(domain,e), - [SUBST('Rep,'_$,x) for x in getFormModemaps([op',:argl],e) - | x is [[ =domain,:.],:.]])) => ans --------> new <------------- - ans := compForm2([op',:argl],m,e:= addDomain(domain,e), - [x for x in getFormModemaps([op',:argl],e) | x is [[ =domain,:.],:.]]) => ans - (op'="construct") and coerceable(domain,m,e) => - (T:= comp([op',:argl],domain,e) or return nil; coerce(T,m)) - nil - - e:= addDomain(m,e) --???unneccessary because of comp2's call??? - (mmList:= getFormModemaps(form,e)) and (T:= compForm2(form,m,e,mmList)) => T - compToApply(op,argl,m,e) - ---% WI and MI - -compForm3(form is [op,:argl],m,e,modemapList) == ---order modemaps so that ones from Rep are moved to the front - modemapList := compFormOrderModemaps(modemapList,m = "$") - qe(22,e) - T:= - or/ - [compFormWithModemap(form,m,e,first (mml:= ml)) - for ml in tails modemapList] or return nil - qt(14,T) - result := - $compUniquelyIfTrue => - or/[compFormWithModemap(form,m,e,mm) for mm in rest mml] => - THROW("compUniquely",nil) - qt(15,T) - qt(16,T) - qt(17,markAny('compForm3,form,result)) - -compFormOrderModemaps(mml,targetIsDollar?) == ---order modemaps so that ones from Rep are moved to the front ---exceptions: if $ is the target and there are 2 modemaps with --- identical signatures, move the $ one ahead - repMms := [mm for (mm:= [[dc,:.],:.]) in mml | dc = 'Rep] - if repMms and targetIsDollar? then - dollarMms := [mm for (mm := [[dc,:sig],:.]) in mml | dc = "$" - and or/[mm1 for (mm1:= [[dc1,:sig1],:.]) in repMms | sig1 = sig]] - repMms := [:dollarMms, :repMms] - null repMms => mml - [:repMms,:SETDIFFERENCE(mml,repMms)] - -compWI(["WI",a,b],m,E) == - u := comp(b,m,E) - pp (u => "====> ok"; 'NO) - u - -compMI(["MI",a,b],m,E) == - u := comp(b,m,E) - pp (u => "====> ok"; 'NO) - u - -compWhere([.,form,:exprList],m,eInit) == - $insideExpressionIfTrue: local:= false - $insideWhereIfTrue: local:= true --- if not $insideFunctorIfTrue then --- $originalTarget := --- form is ['DEF,a,osig,:.] and osig is [otarget,:.] => --- exprList is [['SEQ,:l,['exit,n,y]]] and (u := [:l,y]) and --- (ntarget := or/[def for x in u | x is [op,a',:.,def] and ([op,a',otarget]) and --- MEMQ(op,'(DEF MDEF)) and (a' = otarget or a' is [=otarget])]) => --- [ntarget,:rest osig] --- osig --- nil --- foobum exprList - e:= eInit - u:= - for item in exprList repeat - [.,.,e]:= comp(item,$EmptyMode,e) or return "failed" - u="failed" => return nil - $insideWhereIfTrue:= false - [x,m,eAfter]:= comp(macroExpand(form,eBefore:= e),m,e) or return nil - eFinal:= - del:= deltaContour(eAfter,eBefore) => addContour(del,eInit) - eInit - [x,m,eFinal] - -compMacro(form,m,e) == - $macroIfTrue: local:= true - ["MDEF",lhs,signature,specialCases,rhs]:= form := markKillAll form - firstForm := ["MDEF",first lhs,'(NIL),'(NIL),rhs] - markMacro(first lhs,rhs) - rhs := - rhs is ['CATEGORY,:.] => ['"-- the constructor category"] - rhs is ['Join,:.] => ['"-- the constructor category"] - rhs is ['CAPSULE,:.] => ['"-- the constructor capsule"] - rhs is ['add,:.] => ['"-- the constructor capsule"] - formatUnabbreviated rhs - sayBrightly ['" processing macro definition",'%b, - :formatUnabbreviated lhs,'" ==> ",:rhs,'%d] - ["MDEF",lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e) - m=$EmptyMode or m=$NoValueMode => - ["/throwAway",$NoValueMode,put(first lhs,"macro",rhs,e)] - ---compMacro(form,m,e) == --- $macroIfTrue: local:= true --- ["MDEF",lhs,signature,specialCases,rhs]:= form --- rhs := --- rhs is ['CATEGORY,:.] => ['"-- the constructor category"] --- rhs is ['Join,:.] => ['"-- the constructor category"] --- rhs is ['CAPSULE,:.] => ['"-- the constructor capsule"] --- rhs is ['add,:.] => ['"-- the constructor capsule"] --- formatUnabbreviated rhs --- sayBrightly ['" processing macro definition",'%b, --- :formatUnabbreviated lhs,'" ==> ",:rhs,'%d] --- ["MDEF",lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e) --- m=$EmptyMode or m=$NoValueMode => --- rhs := markMacro(lhs,rhs) --- ["/throwAway",$NoValueMode,put(first lhs,"macro",rhs,e)] - -compSetq(oform,m,E) == - ["LET",form,val] := oform - T := compSetq1(form,val,m,E) => markSetq(oform,T) - nil - -compSetq1(oform,val,m,E) == - form := markKillAll oform - IDENTP form => setqSingle(form,val,m,E) - form is [":",x,y] => - [.,.,E']:= compMakeDeclaration(form,$EmptyMode,E) - compSetq(["LET",x,val],m,E') - form is [op,:l] => - op="CONS" => setqMultiple(uncons form,val,m,E) - op="Tuple" => setqMultiple(l,val,m,E) - setqSetelt(oform,form,val,m,E) - -setqSetelt(oform,[v,:s],val,m,E) == - T:= comp0(["setelt",:oform,val],m,E) or return nil ----> ------- - markComp(oform,T) - -setqSingle(id,val,m,E) == - $insideSetqSingleIfTrue: local:= true - --used for comping domain forms within functions - currentProplist:= getProplist(id,E) - m'':= get(id,'mode,E) or getmode(id,E) or - (if m=$NoValueMode then $EmptyMode else m) ------------------------> new <------------------------- - trialT := m'' = "$" and get("Rep",'value,E) and comp(val,'Rep,E) ------------------------> new <------------------------- - T:= - (trialT and coerce(trialT,m'')) or eval or return nil where - eval() == - T:= comp(val,m'',E) => T - not get(id,"mode",E) and m'' ^= (maxm'':=maxSuperType(m'',E)) and - (T:=comp(val,maxm'',E)) => T - (T:= comp(val,$EmptyMode,E)) and getmode(T.mode,E) => - assignError(val,T.mode,id,m'') - T':= [x,m',e']:= convert(T,m) or return nil - if $profileCompiler = true then - null IDENTP id => nil - key := - MEMQ(id,rest $form) => 'arguments - 'locals - profileRecord(key,id,T.mode) - newProplist:= consProplistOf(id,currentProplist,"value",markKillAll removeEnv T) - e':= (PAIRP id => e'; addBinding(id,newProplist,e')) - x1 := markKillAll x - if isDomainForm(x1,e') then - if isDomainInScope(id,e') then - stackWarning ["domain valued variable","%b",id,"%d", - "has been reassigned within its scope"] - e':= augModemapsFromDomain1(id,x1,e') - --all we do now is to allocate a slot number for lhs - --e.g. the LET form below will be changed by putInLocalDomainReferences ---+ - if (k:=NRTassocIndex(id)) - then - $markFreeStack := [id,:$markFreeStack] - form:=['SETELT,"$",k,x] - else form:= - $QuickLet => ["LET",id,x] - ["LET",id,x, - (isDomainForm(x,e') => ['ELT,id,0];CAR outputComp(id,e'))] - [form,m',e'] - -setqMultiple(nameList,val,m,e) == - val is ["CONS",:.] and m=$NoValueMode => - setqMultipleExplicit(nameList,uncons val,m,e) - val is ["Tuple",:l] and m=$NoValueMode => setqMultipleExplicit(nameList,l,m,e) - --1. create a gensym, %add to local environment, compile and assign rhs - g:= genVariable() - e:= addBinding(g,nil,e) - T:= [.,m1,.]:= compSetq1(g,val,$EmptyMode,e) or return nil - e:= put(g,"mode",m1,e) - [x,m',e]:= convert(T,m) or return nil - --1.1 exit if result is a list - m1 is ["List",D] => - for y in nameList repeat e:= put(y,"value",[genSomeVariable(),D,$noEnv],e) - convert([["PROGN",x,["LET",nameList,g],g],m',e],m) - --2. verify that the #nameList = number of parts of right-hand-side - selectorModePairs:= - --list of modes - decompose(m1,#nameList,e) or return nil where - decompose(t,length,e) == - t is ["Record",:l] => [[name,:mode] for [":",name,mode] in l] - comp(t,$EmptyMode,e) is [.,["RecordCategory",:l],.] => - [[name,:mode] for [":",name,mode] in l] - stackMessage ["no multiple assigns to mode: ",t] - #nameList^=#selectorModePairs => - stackMessage [val," must decompose into ",#nameList," components"] - -- 3.generate code; return - assignList:= - [([.,.,e]:= compSetq1(x,["elt",g,y],z,e) or return "failed").expr - for x in nameList for [y,:z] in selectorModePairs] - if assignList="failed" then NIL - else [MKPROGN [x,:assignList,g],m',e] - -setqMultipleExplicit(nameList,valList,m,e) == - #nameList^=#valList => - stackMessage ["Multiple assignment error; # of items in: ",nameList, - "must = # in: ",valList] - gensymList:= [genVariable() for name in nameList] - for g in gensymList for name in nameList repeat - e := put(g,"mode",get(name,"mode",e),e) - assignList:= - --should be fixed to declare genVar when possible - [[.,.,e]:= compSetq1(g,val,$EmptyMode,e) or return "failed" - for g in gensymList for val in valList for name in nameList] - assignList="failed" => nil - reAssignList:= - [[.,.,e]:= compSetq1(name,g,$EmptyMode,e) or return "failed" - for g in gensymList for name in nameList] - reAssignList="failed" => nil - T := [["PROGN",:[T.expr for T in assignList], - :[T.expr for T in reAssignList]], $NoValueMode, (LAST reAssignList).env] - markMultipleExplicit(nameList,valList,T) - -canReturn(expr,level,exitCount,ValueFlag) == --SPAD: exit and friends - atom expr => ValueFlag and level=exitCount - (op:= first expr)="QUOTE" => ValueFlag and level=exitCount - MEMQ(op,'(WI MI)) => canReturn(CADDR expr,level,count,ValueFlag) - op="TAGGEDexit" => - expr is [.,count,data] => canReturn(data.expr,level,count,count=level) - level=exitCount and not ValueFlag => nil - op="SEQ" => or/[canReturn(u,level+1,exitCount,false) for u in rest expr] - op="TAGGEDreturn" => nil - op="CATCH" => - [.,gs,data]:= expr - (findThrow(gs,data,level,exitCount,ValueFlag) => true) where - findThrow(gs,expr,level,exitCount,ValueFlag) == - atom expr => nil - expr is ["THROW", =gs,data] => true - --this is pessimistic, but I know of no more accurate idea - expr is ["SEQ",:l] => - or/[findThrow(gs,u,level+1,exitCount,ValueFlag) for u in l] - or/[findThrow(gs,u,level,exitCount,ValueFlag) for u in rest expr] - canReturn(data,level,exitCount,ValueFlag) - op = "COND" => - level = exitCount => - or/[canReturn(last u,level,exitCount,ValueFlag) for u in rest expr] - or/[or/[canReturn(u,level,exitCount,ValueFlag) for u in v] - for v in rest expr] - op="IF" => - expr is [.,a,b,c] - if not canReturn(a,0,0,true) and not (BOUNDP '$convert2NewCompiler and $convert2NewCompiler) then - SAY "IF statement can not cause consequents to be executed" - pp expr - canReturn(a,level,exitCount,nil) or canReturn(b,level,exitCount,ValueFlag) - or canReturn(c,level,exitCount,ValueFlag) - --now we have an ordinary form - atom op => and/[canReturn(u,level,exitCount,ValueFlag) for u in expr] - op is ["XLAM",args,bods] => - and/[canReturn(u,level,exitCount,ValueFlag) for u in expr] - systemErrorHere '"canReturn" --for the time being - -compList(l,m is ["List",mUnder],e) == - markImport m - markImport mUnder - null l => [NIL,m,e] - Tl:= [[.,mUnder,e]:= - comp(x,mUnder,e) or return "failed" for i in 1.. for x in l] - Tl="failed" => nil - T:= [["LIST",:[T.expr for T in Tl]],["List",mUnder],e] - -compVector(l,m is ["Vector",mUnder],e) == - markImport m - markImport mUnder - null l => [$EmptyVector,m,e] - Tl:= [[.,mUnder,e]:= comp(x,mUnder,e) or return "failed" for x in l] - Tl="failed" => nil - [["VECTOR",:[T.expr for T in Tl]],m,e] - -compColon([":",f,t],m,e) == - $insideExpressionIfTrue=true => compPretend(["pretend",f,t],m,e) - --if inside an expression, ":" means to convert to m "on faith" - f := markKillAll f - $lhsOfColon: local:= f - t:= - t := markKillAll t - atom t and (t':= ASSOC(t,getDomainsInScope e)) => t' - isDomainForm(t,e) and not $insideCategoryIfTrue => - (if not member(t,getDomainsInScope e) then e:= addDomain(t,e); t) - isDomainForm(t,e) or isCategoryForm(t,e) => t - t is ["Mapping",m',:r] => t - unknownTypeError t - t - if $insideCapsuleFunctionIfTrue then markDeclaredImport t - f is ["LISTOF",:l] => - (for x in l repeat T:= [.,.,e]:= compColon([":",x,t],m,e); T) - e:= - f is [op,:argl] and not (t is ["Mapping",:.]) => - --for MPOLY--replace parameters by formal arguments: RDJ 3/83 - newTarget:= EQSUBSTLIST(take(#argl,$FormalMapVariableList), - [(x is [":",a,m] => a; x) for x in argl],t) - signature:= - ["Mapping",newTarget,: - [(x is [":",a,m] => m; - getmode(x,e) or systemErrorHere '"compColonOld") for x in argl]] - put(op,"mode",signature,e) - put(f,"mode",t,e) - if not $bootStrapMode and $insideFunctorIfTrue and - makeCategoryForm(t,e) is [catform,e] then - e:= put(f,"value",[genSomeVariable(),t,$noEnv],e) - ["/throwAway",getmode(f,e),e] - -compConstruct(form,m,e) == (T := compConstruct1(form,m,e)) and markConstruct(form,T) - -compConstruct1(form is ["construct",:l],m,e) == - y:= modeIsAggregateOf("List",m,e) => - T:= compList(l,["List",CADR y],e) => convert(T,m) - y:= modeIsAggregateOf("Vector",m,e) => - T:= compVector(l,["Vector",CADR y],e) => convert(T,m) - T:= compForm(form,m,e) => T - for D in getDomainsInScope e repeat - (y:=modeIsAggregateOf("List",D,e)) and - (T:= compList(l,["List",CADR y],e)) and (T':= convert(T,m)) => - return T' - (y:=modeIsAggregateOf("Vector",D,e)) and - (T:= compVector(l,["Vector",CADR y],e)) and (T':= convert(T,m)) => - return T' - -compPretend(u := ["pretend",x,t],m,e) == - t := markKillAll t - m := markKillAll m - e:= addDomain(t,e) - T:= comp(x,t,e) or comp(x,$EmptyMode,e) or return nil - if T.mode=t then warningMessage:= ["pretend",t," -- should replace by @"] - T1:= [T.expr,t,T.env] - t = "$" and m = "Rep" => markPretend(T1,T1) -->! WATCH OUT: correct? !<-- - T':= coerce(T1,m) => - warningMessage => - stackWarning warningMessage - markCompColonInside("@",T') - markPretend(T1,T') - nil - -compAtSign(["@",x,m'],m,e) == - m' := markKillAll m' - m := markKillAll m - e:= addDomain(m',e) - T:= comp(x,m',e) or return nil - coerce(T,m) - -compColonInside(x,m,e,m') == - m' := markKillAll m' - e:= addDomain(m',e) - T:= comp(x,$EmptyMode,e) or return nil - if T.mode=m' then warningMessage:= [":",m'," -- should replace by ::"] - T:= [T.expr,m',T.env] - m := markKillAll m - T':= coerce(T,m) => - warningMessage => - stackWarning warningMessage - markCompColonInside("@",T') - stackWarning [":",m'," -- should replace by pretend"] - markCompColonInside("pretend",T') - nil - -resolve(min, mout) == - din := markKillAll min - dout := markKillAll mout - din=$NoValueMode or dout=$NoValueMode => $NoValueMode - dout=$EmptyMode => din - STRINGP din and dout = '(Symbol) => dout ------> hack 8/14/94 - STRINGP dout and din = '(Symbol) => din ------> hack 8/14/94 - din^=dout and (STRINGP din or STRINGP dout) => - modeEqual(dout,$String) => dout - modeEqual(din,$String) => nil - mkUnion(din,dout) - dout - -coerce(T,m) == - T := [T.expr,markKillAll T.mode,T.env] - m := markKillAll m - if not get(m, 'isLiteral,T.env) then markImport m - $InteractiveMode => - keyedSystemError("S2GE0016",['"coerce", - '"function coerce called from the interpreter."]) ---==================> changes <====================== ---The following line is inappropriate for our needs::: ---rplac(CADR T,substitute("$",$Rep,CADR T)) - T' := coerce0(T,m) => T' - T := [T.expr,fullSubstitute("$",$Representation,T.mode),T.env] ---==================> changes <====================== - coerce0(T,m) - -coerce0(T,m) == - T':= coerceEasy(T,m) => T' - T':= coerceSubset(T,m) => markCoerce(T,T','AUTOSUBSET) - T':= coerceHard(T,m) => markCoerce(T,T','AUTOHARD) - T':= coerceExtraHard(T,m) => T' - T.expr = "$fromCoerceable$" or isSomeDomainVariable m => nil - T' := coerceRep(T,m) => markCoerce(T,T','AUTOREP) - stackMessage fn(T.expr,T.mode,m) where - -- if from from coerceable, this coerce was just a trial coercion - -- from compFormWithModemap to filter through the modemaps - fn(x,m1,m2) == - ["Cannot coerce","%b",x,"%d","%l"," of mode","%b",m1,"%d","%l", - " to mode","%b",m2,"%d"] - -coerceSubset(T := [x,m,e],m') == - m = $SmallInteger => - m' = $Integer => [x,m',e] - m' = (r := get(x,'range,e)) or isSubset(r,m',e) => [x,r,e] - nil --- pp [m, m'] - isSubset(m,m',e) or m="Rep" and m'="$" => [x,m',e] - m is ['SubDomain,=m',:.] => [x,m',e] - (pred:= LASSOC(opOf m',get(opOf m,'SubDomain,e))) and INTEGERP x and - -- obviously this is temporary - eval substitute(x,"#1",pred) => [x,m',e] - (pred:= isSubset(m',maxSuperType(m,e),e)) and INTEGERP x -- again temporary - and eval substitute(x,"*",pred) => - [x,m',e] - nil - -coerceRep(T,m) == - md := T.mode - atom md => nil - CONTAINED('Rep,md) and SUBST('$,'Rep,md) = m or - CONTAINED('Rep,m) and SUBST('$,'Rep,m) = md => T - nil - ---- GET rid of XLAMs -spadCompileOrSetq form == - --bizarre hack to take account of the existence of "known" functions - --good for performance (LISPLLIB size, BPI size, NILSEC) - [nam,[lam,vl,body]] := form - CONTAINED(" ",body) => sayBrightly ['" ",:bright nam,'" not compiled"] - if vl is [:vl',E] and body is [nam',: =vl'] then - LAM_,EVALANDFILEACTQ ['PUT,MKQ nam,MKQ 'SPADreplace,MKQ nam'] - sayBrightly ['" ",:bright nam,'"is replaced by",:bright nam'] - else if (ATOM body or and/[ATOM x for x in body]) - and vl is [:vl',E] and not CONTAINED(E,body) then - macform := ['XLAM,vl',body] - LAM_,EVALANDFILEACTQ ['PUT,MKQ nam,MKQ 'SPADreplace,MKQ macform] - sayBrightly ['" ",:bright nam,'"is replaced by",:bright body] - $insideCapsuleFunctionIfTrue => first COMP LIST form - compileConstructor form - -coerceHard(T,m) == - $e: local:= T.env - m':= T.mode - STRINGP m' and modeEqual(m,$String) => [T.expr,m,$e] - modeEqual(m',m) or - (get(m',"value",$e) is [m'',:.] or getmode(m',$e) is ["Mapping",m'']) and - modeEqual(m'',m) or - (get(m,"value",$e) is [m'',:.] or getmode(m,$e) is ["Mapping",m'']) and - modeEqual(m'',m') => [T.expr,m,T.env] - STRINGP T.expr and T.expr=m => [T.expr,m,$e] - isCategoryForm(m,$e) => - $bootStrapMode = true => [T.expr,m,$e] - extendsCategoryForm(T.expr,T.mode,m) => [T.expr,m,$e] - nil - nil - -coerceExtraHard(T is [x,m',e],m) == - T':= autoCoerceByModemap(T,m) => T' - isUnionMode(m',e) is ["Union",:l] and (t:= hasType(x,e)) and - member(t,l) and (T':= autoCoerceByModemap(T,t)) and - (T'':= coerce(T',m)) => T'' - m' is ['Record,:.] and m = $Expression => - [['coerceRe2E,x,['ELT,COPY m',0]],m,e] - nil - -compCoerce(u := ["::",x,m'],m,e) == - m' := markKillAll m' - e:= addDomain(m',e) - m := markKillAll m ---------------> new code <------------------- - T:= compCoerce1(x,m',e) => coerce(T,m) - T := comp(x,$EmptyMode,e) or return nil - T.mode = $SmallInteger and - MEMQ(opOf m,'(NonNegativeInteger PositiveInteger)) => - compCoerce(["::",["::",x,$Integer],m'],m,e) ---------------> new code <------------------- - getmode(m',e) is ["Mapping",["UnionCategory",:l]] => - l := [markKillAll x for x in l] - T:= (or/[compCoerce1(x,m1,e) for m1 in l]) or return nil - coerce([T.expr,m',T.env],m) - -compCoerce1(x,m',e) == - T:= comp(x,m',e) - if null T then T := comp(x,$EmptyMode,e) - null T => return nil - m1:= - STRINGP T.mode => $String - T.mode - m':=resolve(m1,m') - T:=[T.expr,m1,T.env] - T':= coerce(T,m') => T' - T':= coerceByModemap(T,m') => T' - pred:=isSubset(m',T.mode,e) => - gg:=GENSYM() - pred:= substitute(gg,"*",pred) - code:= ['PROG1,['LET,gg,T.expr], ['check_-subtype,pred,MKQ m',gg]] - [code,m',T.env] - -coerceByModemap([x,m,e],m') == ---+ modified 6/27 for new runtime system - u:= - [modemap - for (modemap:= [map,cexpr]) in getModemapList("coerce",1,e) | map is [.,t, - s] and (modeEqual(t,m') or isSubset(t,m',e)) - and (modeEqual(s,m) or isSubset(m,s,e))] or return nil - mm:=first u -- patch for non-trival conditons - fn := genDeltaEntry ['coerce,:mm] - T := [["call",fn,x],m',e] - markCoerceByModemap(x,m,m',markCallCoerce(x,m',T),nil) - -autoCoerceByModemap([x,source,e],target) == - u:= - [cexpr - for (modemap:= [map,cexpr]) in getModemapList("autoCoerce",1,e) | map is [ - .,t,s] and modeEqual(t,target) and modeEqual(s,source)] or return nil - fn:= (or/[selfn for [cond,selfn] in u | cond=true]) or return nil - markCoerceByModemap(x,source,target,[["call",fn,x],target,e],true) - ---====================================================================== --- From compiler.boot ---====================================================================== ---comp3x(x,m,$e) == - -comp3(x,m,$e) == - --returns a Triple or %else nil to signalcan't do' - $e:= addDomain(m,$e) - e:= $e --for debugging purposes - m is ["Mapping",:.] => compWithMappingMode(x,m,e) - m is ["QUOTE",a] => (x=a => [x,m,$e]; nil) - STRINGP m => (atom x => (m=x or m=STRINGIMAGE x => [m,m,e]; nil); nil) - ^x or atom x => compAtom(x,m,e) - op:= first x - getmode(op,e) is ["Mapping",:ml] and (u:= applyMapping(x,m,e,ml)) => u - op is ["KAPPA",sig,varlist,body] => compApply(sig,varlist,body,rest x,m,e) - op=":" => compColon(x,m,e) - op="::" => compCoerce(x,m,e) - not ($insideCompTypeOf=true) and stringPrefix?('"TypeOf",PNAME op) => - compTypeOf(x,m,e) - ------------special jump out code for PART (don't want $insideExpressionIfTrue=true)-- - x is ['PART,:.] => compPART(x,m,e) - ---------------------------------- - t:= qt(14,compExpression(x,m,e)) - t is [x',m',e'] and not member(m',getDomainsInScope e') => - qt(15,[x',m',addDomain(m',e')]) - qt(16,t) - -yyyyy x == x -compExpression(x,m,e) == - $insideExpressionIfTrue: local:= true - if x is ['LET,['PART,.,w],[['elt,B,'new],['PART,.,["#",['PART,.,l]]],:.],:.] then yyyyy x - x := compRenameOp x - atom first x and (fn:= GETL(first x,"SPECIAL")) => - FUNCALL(fn,x,m,e) - compForm(x,m,e) - -compRenameOp x == ----------> new 12/3/94 - x is [op,:r] and op is ['PART,.,op1] => - [op1,:r] - x - -compCase(["case",x,m1],m,e) == - m' := markKillAll m1 - e:= addDomain(m',e) - T:= compCase1(x,m',e) => coerce(T,m) - nil - -compCase1(x,m,e) == - x1 := - x is ['PART,.,a] => a - x - [x',m',e']:= comp(x1,$EmptyMode,e) or return nil - if m' = "$" then (m' := IFCAR get('Rep,'value,e)) and (switchMode := true) - -------------------------------------------------------------------------- - m' isnt ['Union,:r] => nil - mml := [mm for (mm := [map,cexpr]) in getModemapList("case",2,e') - | map is [.,.,s,t] and modeEqual(t,m) and - (modeEqual(s,m') or switchMode and modeEqual(s,"$"))] - or return nil - u := [cexpr for [.,cexpr] in mml] - fn:= (or/[selfn for [cond,selfn] in u | cond=true]) or return nil - tag := genCaseTag(m, r, 1) or return nil - x1 := - switchMode => markRepper('rep, x) - x - markCase(x, tag, markCaseWas(x1,[["call",fn,x'],$Boolean,e'])) - -genCaseTag(t,l,n) == - l is [x, :l] => - x = t => - STRINGP x => INTERN x - INTERN STRCONC("value", STRINGIMAGE n) - x is ["::",=t,:.] => t - STRINGP x => genCaseTag(t, l, n) - genCaseTag(t, l, n + 1) - nil - -compIf(["IF",aOrig,b,c],m,E) == - a := markKillButIfs aOrig - [xa,ma,Ea,Einv]:= compBoolean(a,aOrig,$Boolean,E) or return nil - [xb,mb,Eb]:= Tb:= compFromIf(b,m,Ea) or return nil - [xc,mc,Ec]:= Tc:= compFromIf(c,resolve(mb,m),Einv) or return nil - xb':= coerce(Tb,mc) or return nil - x:= ["IF",xa,quotify xb'.expr,quotify xc] - (returnEnv:= Env(xb'.env,Ec,xb'.expr,xc,E)) where - Env(bEnv,cEnv,b,c,E) == - canReturn(b,0,0,true) => - (canReturn(c,0,0,true) => intersectionEnvironment(bEnv,cEnv); bEnv) - canReturn(c,0,0,true) => cEnv - E - [x,mc,returnEnv] - -compBoolean(p,pWas,m,Einit) == - op := opOf p - [p',m,E]:= - fop := LASSOC(op,'((and . compAnd) (or . compOr) (not . compNot))) => - APPLY(fop,[p,pWas,m,Einit]) or return nil - T := comp(p,m,Einit) or return nil - markAny('compBoolean,pWas,T) - [p',m,getSuccessEnvironment(markKillAll p,E), - getInverseEnvironment(markKillAll p,E)] - -compAnd([op,:args], pWas, m, e) == ---called ONLY from compBoolean - cargs := [T.expr for x in args - | [.,.,e,.] := T := compBoolean(x,x,$Boolean,e) or return nil] - null cargs => nil - coerce(markAny('compAnd,pWas,[["AND",:cargs],$Boolean,e]),m) - -compOr([op,:args], pWas, m, e) == ---called ONLY from compBoolean - cargs := [T.expr for x in args - | [.,.,.,e] := T := compBoolean(x,x,$Boolean,e) or return nil] - null cargs => nil - coerce(markAny('compOr,pWas, [["OR",:cargs],$Boolean,e]),m) - -compNot([op,arg], pWas, m, e) == ---called ONLY from compBoolean - [x,m1,.,ei] := compBoolean(arg,arg,$Boolean,e) or return nil - coerce(markAny('compNot, pWas, [["NOT",x],$Boolean,ei]),m) - -compDefine(form,m,e) == - $tripleHits: local:= 0 - $macroIfTrue: local - $packagesUsed: local - ['DEF,.,originalSignature,.,body] := form - if not $insideFunctorIfTrue then - $originalBody := COPY body - compDefine1(form,m,e) - -compDefine1(form,m,e) == - $insideExpressionIfTrue: local:= false - --1. decompose after macro-expanding form - ['DEF,lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e) - $insideWhereIfTrue and isMacro(form,e) and (m=$EmptyMode or m=$NoValueMode) - => [lhs,m,put(first lhs,'macro,rhs,e)] - null signature.target and not MEMQ(KAR rhs,$ConstructorNames) and - (sig:= getSignatureFromMode(lhs,e)) => - -- here signature of lhs is determined by a previous declaration - compDefine1(['DEF,lhs,[first sig,:rest signature],specialCases,rhs],m,e) - if signature.target=$Category then $insideCategoryIfTrue:= true - if signature.target is ['Mapping,:map] then - signature:= map - form:= ['DEF,lhs,signature,specialCases,rhs] - - --- RDJ (11/83): when argument and return types are all declared, --- or arguments have types declared in the environment, --- and there is no existing modemap for this signature, add --- the modemap by a declaration, then strip off declarations and recurse - e := compDefineAddSignature(lhs,signature,e) --- 2. if signature list for arguments is not empty, replace ('DEF,..) by --- ('where,('DEF,..),..) with an empty signature list; --- otherwise, fill in all NILs in the signature - not (and/[null x for x in rest signature]) => compDefWhereClause(form,m,e) - signature.target=$Category => - compDefineCategory(form,m,e,nil,$formalArgList) - isDomainForm(rhs,e) and not $insideFunctorIfTrue => - if null signature.target then signature:= - [getTargetFromRhs(lhs,rhs,giveFormalParametersValues(rest lhs,e)),: - rest signature] - rhs:= addEmptyCapsuleIfNecessary(signature.target,rhs) - compDefineFunctor(['DEF,lhs,signature,specialCases,rhs],m,e,nil, - $formalArgList) - null $form => stackAndThrow ['"bad == form ",form] - newPrefix:= - $prefix => INTERN STRCONC(encodeItem $prefix,'",",encodeItem $op) - getAbbreviation($op,#rest $form) - compDefineCapsuleFunction(form,m,e,newPrefix,$formalArgList) - -compDefineCategory(df,m,e,prefix,fal) == - $domainShell: local -- holds the category of the object being compiled - $lisplibCategory: local - not $insideFunctorIfTrue and $LISPLIB => - compDefineLisplib(df,m,e,prefix,fal,'compDefineCategory1) - compDefineCategory1(df,m,e,prefix,fal) - -compDefineCategory1(df,m,e,prefix,fal) == - $DEFdepth : local := 0 --for conversion to new compiler 3/93 - $capsuleStack : local := nil --for conversion to new compiler 3/93 - $predicateStack:local := nil --for conversion to new compiler 3/93 - $signatureStack:local := nil --for conversion to new compiler 3/93 - $importStack : local := nil --for conversion to new compiler 3/93 - $globalImportStack : local := nil --for conversion to new compiler 3/93 - $catAddForm : local := nil --for conversion to new compiler 2/95 - $globalDeclareStack : local := nil - $globalImportDefAlist: local:= nil - $localMacroStack : local := nil --for conversion to new compiler 3/93 - $freeStack : local := nil --for conversion to new compiler 3/93 - $domainLevelVariableList: local := nil--for conversion to new compiler 3/93 - $categoryTranForm : local := nil --for conversion to new compiler 10/93 - ['DEF,form,sig,sc,body] := df - body := markKillAll body --these parts will be replaced by compDefineLisplib - categoryCapsule := ---+ - body is ['add,cat,capsule] => - body := cat - capsule - nil - [d,m,e]:= compDefineCategory2(form,sig,sc,body,m,e,prefix,fal) ---+ next two lines --- if BOUNDP '$convertingSpadFile and $convertingSpadFile then nil --- else - if categoryCapsule and not $bootStrapMode then - [.,.,e] := - $insideCategoryPackageIfTrue: local := true --see NRTmakeSlot1 - $categoryPredicateList: local := - makeCategoryPredicates(form,$lisplibCategory) - defform := mkCategoryPackage(form,cat,categoryCapsule) - ['DEF,[.,arg,:.],:.] := defform - $categoryNameForDollar :local := arg - compDefine1(defform,$EmptyMode,e) - else - [body,T] := $categoryTranForm - markFinish(body,T) - - [d,m,e] - -compDefineCategory2(form,signature,specialCases,body,m,e, - $prefix,$formalArgList) == - --1. bind global variables - $insideCategoryIfTrue: local:= true - $TOP__LEVEL: local - $definition: local - --used by DomainSubstitutionFunction - $form: local - $op: local - $extraParms: local - --Set in DomainSubstitutionFunction, used further down --- 1.1 augment e to add declaration $: - [$op,:argl]:= $definition:= form - e:= addBinding("$",[['mode,:$definition]],e) - --- 2. obtain signature - signature':= - [first signature,:[getArgumentModeOrMoan(a,$definition,e) for a in argl]] - e:= giveFormalParametersValues(argl,e) - --- 3. replace arguments by $1,..., substitute into body, --- and introduce declarations into environment - sargl:= TAKE(# argl, $TriangleVariableList) - $functorForm:= $form:= [$op,:sargl] - $formalArgList:= [:sargl,:$formalArgList] - aList:= [[a,:sa] for a in argl for sa in sargl] - formalBody:= SUBLIS(aList,body) - signature' := SUBLIS(aList,signature') ---Begin lines for category default definitions - $functionStats: local:= [0,0] - $functorStats: local:= [0,0] - $frontier: local := 0 - $getDomainCode: local := nil - $addForm: local:= nil - for x in sargl for t in rest signature' repeat - [.,.,e]:= compMakeDeclaration([":",x,t],m,e) - --- 4. compile body in environment of %type declarations for arguments - op':= $op - -- following line causes cats with no with or Join to be fresh copies - if opOf(formalBody)^='Join and opOf(formalBody)^='mkCategory then - formalBody := ['Join, formalBody] - T := compOrCroak(formalBody,signature'.target,e) ---------------------> new <------------------- - $catAddForm := - $originalBody is ['add,y,:.] => y - $originalBody - $categoryTranForm := [$originalBody,[$form,['Mapping,:signature'],T.env]] ---------------------> new <------------------- - body:= optFunctorBody markKillAll T.expr - if $extraParms then - formals:=actuals:=nil - for u in $extraParms repeat - formals:=[CAR u,:formals] - actuals:=[MKQ CDR u,:actuals] - body := ['sublisV,['PAIR,['QUOTE,formals],['LIST,:actuals]],body] - if argl then body:= -- always subst for args after extraparms - ['sublisV,['PAIR,['QUOTE,sargl],['LIST,: - [['devaluate,u] for u in sargl]]],body] - body:= - ['PROG1,['LET,g:= GENSYM(),body],['SETELT,g,0,mkConstructor $functorForm]] - fun:= compile [op',['LAM,sargl,body]] - --- 5. give operator a 'modemap property - pairlis:= [[a,:v] for a in argl for v in $FormalMapVariableList] - parSignature:= SUBLIS(pairlis,signature') - parForm:= SUBLIS(pairlis,form) ----- lisplibWrite('"compilerInfo", ----- ['SETQ,'$CategoryFrame, ----- ['put,['QUOTE,op'],' ----- (QUOTE isCategory),true,['addModemap,MKQ op',MKQ parForm, ----- MKQ parSignature,true,MKQ fun,'$CategoryFrame]]],$libFile) - --Equivalent to the following two lines, we hope - if null sargl then - evalAndRwriteLispForm('NILADIC, - ['MAKEPROP,['QUOTE,op'],'(QUOTE NILADIC),true]) - --- 6. put modemaps into InteractiveModemapFrame - $domainShell := - BOUNDP '$convertingSpadFile and $convertingSpadFile => nil - eval [op',:MAPCAR('MKQ,sargl)] - $lisplibCategory:= formalBody ----- if $LISPLIB then ----- $lisplibForm:= form ----- $lisplibKind:= 'category ----- modemap:= [[parForm,:parSignature],[true,op']] ----- $lisplibModemap:= modemap ----- $lisplibCategory:= formalBody ----- form':=[op',:sargl] ----- augLisplibModemapsFromCategory(form',formalBody,signature') - [fun,'(Category),e] -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/wi2.boot b/src/interp/wi2.boot new file mode 100644 index 00000000..4c8035ac --- /dev/null +++ b/src/interp/wi2.boot @@ -0,0 +1,1231 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- 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" + +compDefineFunctor1(df, m,$e,$prefix,$formalArgList) == + ['DEF,form,signature,$functorSpecialCases,body] := df + signature := markKillAll signature + if NRTPARSE = true then + [lineNumber,:$functorSpecialCases] := $functorSpecialCases +-- 1. bind global variables + $addForm: local + $viewNames: local:= nil + + --This list is only used in genDomainViewName, for generating names + --for alternate views, if they do not already exist. + --format: Alist: (domain name . sublist) + --sublist is alist: category . name of view + $functionStats: local:= [0,0] + $functorStats: local:= [0,0] + $DEFdepth : local := 0 --for conversion to new compiler 3/93 + $capsuleStack : local := nil --for conversion to new compiler 3/93 + $predicateStack:local := nil --for conversion to new compiler 3/93 + $signatureStack:local := nil --for conversion to new compiler 3/93 + $importStack : local := nil --for conversion to new compiler 3/93 + $globalImportStack : local := nil --for conversion to new compiler 3/93 + $globalDeclareStack : local := nil + $globalImportDefAlist: local:= nil + $localMacroStack : local := nil --for conversion to new compiler 3/93 + $freeStack : local := nil --for conversion to new compiler 3/93 + $domainLevelVariableList: local := nil--for conversion to new compiler 3/93 + $localLoopVariables: local := nil + $pathStack : local := nil + $form: local + $op: local + $signature: local + $functorTarget: local + $Representation: local + --Set in doIt, accessed in the compiler - compNoStacking + $LocalDomainAlist: local --set in doIt, accessed in genDeltaEntry + $LocalDomainAlist:= nil + $functorForm: local + $functorLocalParameters: local + $CheckVectorList: local + --prevents CheckVector from printing out same message twice + $getDomainCode: local -- code for getting views + $insideFunctorIfTrue: local:= true + $functorsUsed: local --not currently used, finds dependent functors + $setelt: local := + $QuickCode = true => 'QSETREFV + 'SETELT + $TOP__LEVEL: local + $genSDVar: local:= 0 + originale:= $e + [$op,:argl]:= form + $formalArgList:= [:argl,:$formalArgList] + $pairlis := [[a,:v] for a in argl for v in $FormalMapVariableList] + $mutableDomain: local := + -- all defaulting packages should have caching turned off + isCategoryPackageName $op or + (if BOUNDP '$mutableDomains then MEMQ($op,$mutableDomains) + else false ) --true if domain has mutable state + signature':= + [first signature,:[getArgumentModeOrMoan(a,form,$e) for a in argl]] + $functorForm:= $form:= [$op,:argl] + $globalImportStack := + [markKillAll x for x in rest $functorForm for typ in rest signature' + | GETDATABASE(opOf typ,'CONSTRUCTORKIND) = 'category] + if null first signature' then signature':= + modemap2Signature getModemap($form,$e) + target:= first signature' + $functorTarget:= target + $e:= giveFormalParametersValues(argl,$e) + [ds,.,$e]:= compMakeCategoryObject(target,$e) or +--+ copy needed since slot1 is reset; compMake.. can return a cached vector + sayBrightly '" cannot produce category object:" + pp target + return nil + $domainShell:= COPY_-SEQ ds + $attributesName:local := INTERN STRCONC(PNAME $op,'";attributes") + attributeList := ds.2 --see below under "loadTimeAlist" +--+ 7 lines for $NRT follow + $goGetList: local := nil +-->--these globals used by NRTmakeCategoryAlist, set by NRTsetVector4Part1 + $condAlist: local := nil + $uncondAlist: local := nil +-->>-- next global initialized here, reset by NRTbuildFunctor + $NRTslot1PredicateList: local := + REMDUP [CADR x for x in attributeList] +-->>-- next global initialized here, used by NRTgenAttributeAlist (NRUNOPT) + $NRTattributeAlist: local := NRTgenInitialAttributeAlist attributeList + $NRTslot1Info: local --set in NRTmakeSlot1 called by NRTbuildFunctor + --this is used below to set $lisplibSlot1 global + $NRTbase: local := 6 -- equals length of $domainShell + $NRTaddForm: local := nil -- see compAdd; NRTmakeSlot1 + $NRTdeltaList: local := nil --list of misc. elts used in compiled fncts + $NRTdeltaListComp: local := nil --list of COMP-ed forms for $NRTdeltaList + $NRTaddList: local := nil --list of fncts not defined in capsule (added) + $NRTdeltaLength: local := 0 -- =length of block of extra entries in vector + $NRTloadTimeAlist: local := nil --used for things in slot4 (NRTsetVector4) + $NRTdomainFormList: local := nil -- of form ((gensym . (Repe...)) ... + -- the above optimizes the calls to local domains + $template: local:= nil --stored in the lisplib (if $NRTvec = true) + $functionLocations: local := nil --locations of defined functions in source + -- generate slots for arguments first, then for $NRTaddForm in compAdd + for x in argl repeat NRTgetLocalIndex x + [.,.,$e]:= compMakeDeclaration([":",'_$,target],m,$e) + --The following loop sees if we can economise on ADDed operations + --by using those of Rep, if that is the same. Example: DIRPROD + if $insideCategoryPackageIfTrue^= true then + if body is ['add,ab:=[fn,:.],['CAPSULE,:cb]] and MEMQ(fn,'(List Vector)) + and FindRep(cb) = ab + where FindRep cb == + u:= + while cb repeat + ATOM cb => return nil + cb is [['LET,'Rep,v,:.],:.] => return (u:=v) + cb:=CDR cb + u + then $e:= augModemapsFromCategoryRep('_$,ab,cb,target,$e) + else $e:= augModemapsFromCategory('_$,'_$,'_$,target,$e) + $signature:= signature' + operationAlist:= SUBLIS($pairlis,$domainShell.(1)) + parSignature:= SUBLIS($pairlis,signature') + parForm:= SUBLIS($pairlis,form) + +-- (3.1) now make a list of the functor's local parameters; for +-- domain D in argl,check its signature: if domain, its type is Join(A1,..,An); +-- in this case, D is replaced by D1,..,Dn (gensyms) which are set +-- to the A1,..,An view of D + if isPackageFunction() then $functorLocalParameters:= + [nil,: + [nil + for i in 6..MAXINDEX $domainShell | + $domainShell.i is [.,.,['ELT,'_$,.]]]] + --leave space for vector ops and package name to be stored +--+ + $functorLocalParameters:= + argPars := + makeFunctorArgumentParameters(argl,rest signature',first signature') + -- must do above to bring categories into scope --see line 5 of genDomainView + argl +-- 4. compile body in environment of %type declarations for arguments + op':= $op + rettype:= signature'.target + SETQ($myFunctorBody, body) --------> new <-------- + T:= compFunctorBody(body,rettype,$e,parForm) +---------------> new <--------------------- + BOUNDP '$convert2NewCompiler and $convert2NewCompiler => + return markFinish($originalBody,[$form,['Mapping,:signature'],T.env]) +---------------> new <--------------------- + -- If only compiling certain items, then ignore the body shell. + $compileOnlyCertainItems => + reportOnFunctorCompilation() + [nil, ['Mapping, :signature'], originale] + + body':= T.expr + lamOrSlam:= if $mutableDomain then 'LAM else 'SPADSLAM + fun:= compile SUBLIS($pairlis, [op',[lamOrSlam,argl,body']]) + --The above statement stops substitutions gettting in one another's way +--+ + operationAlist := SUBLIS($pairlis,$lisplibOperationAlist) + if $LISPLIB then + augmentLisplibModemapsFromFunctor(parForm,operationAlist,parSignature) + reportOnFunctorCompilation() + +-- 5. give operator a 'modemap property +-- if $functorsUsed then MAKEPROP(op',"NEEDS",$functorsUsed) + $insideFunctorIfTrue:= false + if $LISPLIB then + $lisplibKind:= + $functorTarget is ["CATEGORY",key,:.] and key^="domain" => 'package + 'domain + $lisplibForm:= form + modemap:= [[parForm,:parSignature],[true,op']] + $lisplibModemap:= modemap + if null $bootStrapMode then + $NRTslot1Info := NRTmakeSlot1Info() + $isOpPackageName: local := isCategoryPackageName $op + if $isOpPackageName then lisplibWrite('"slot1DataBase", + ['updateSlot1DataBase,MKQ $NRTslot1Info],$libFile) + $lisplibFunctionLocations := SUBLIS($pairlis,$functionLocations) + $lisplibCategoriesExtended := SUBLIS($pairlis,$lisplibCategoriesExtended) + -- see NRTsetVector4 for initial setting of $lisplibCategoriesExtended + libFn := getConstructorAbbreviation op' + $lookupFunction: local := + NRTgetLookupFunction($functorForm,CADAR $lisplibModemap,$NRTaddForm) + --either lookupComplete (for forgetful guys) or lookupIncomplete + $byteAddress :local := 0 + $byteVec :local := nil + $NRTslot1PredicateList := + [simpBool x for x in $NRTslot1PredicateList] + rwriteLispForm('loadTimeStuff, + ['MAKEPROP,MKQ $op,''infovec,getInfovecCode()]) + $lisplibSlot1 := $NRTslot1Info --NIL or set by $NRTmakeSlot1 + $lisplibOperationAlist:= operationAlist + $lisplibMissingFunctions:= $CheckVectorList + lisplibWrite('"compilerInfo", + ['SETQ,'$CategoryFrame, + ['put,['QUOTE,op'],' + (QUOTE isFunctor), + ['QUOTE,operationAlist],['addModemap,['QUOTE,op'],[' + QUOTE,parForm],['QUOTE,parSignature],true,['QUOTE,op'], + ['put,['QUOTE,op' ],'(QUOTE mode), + ['QUOTE,['Mapping,:parSignature]],'$CategoryFrame]]]], $libFile) + if null argl then + evalAndRwriteLispForm('NILADIC, + ['MAKEPROP, ['QUOTE,op'], ['QUOTE,'NILADIC], true]) + [fun,['Mapping,:signature'],originale] + +makeFunctorArgumentParameters(argl,sigl,target) == + $alternateViewList: local:= nil + $forceAdd: local:= true + $ConditionalOperators: local + target := markKillAll target + ("append"/[fn(a,augmentSig(s,findExtras(a,target))) + for a in argl for s in sigl]) where + findExtras(a,target) == + -- see if conditional information implies anything else + -- in the signature of a + target is ['Join,:l] => "union"/[findExtras(a,x) for x in l] + target is ['CATEGORY,.,:l] => "union"/[findExtras1(a,x) for x in l] where + findExtras1(a,x) == + x is ['AND,:l] => "union"/[findExtras1(a,y) for y in l] + x is ['OR,:l] => "union"/[findExtras1(a,y) for y in l] + x is ['IF,c,p,q] => + union(findExtrasP(a,c), + union(findExtras1(a,p),findExtras1(a,q))) where + findExtrasP(a,x) == + x is ['AND,:l] => "union"/[findExtrasP(a,y) for y in l] + x is ['OR,:l] => "union"/[findExtrasP(a,y) for y in l] + x is ['has,=a,y] and y is ['SIGNATURE,:.] => [y] + nil + nil + augmentSig(s,ss) == + -- if we find something extra, add it to the signature + null ss => s + for u in ss repeat + $ConditionalOperators:=[CDR u,:$ConditionalOperators] + s is ['Join,:sl] => + u:=ASSQ('CATEGORY,ss) => + SUBST([:u,:ss],u,s) + ['Join,:sl,['CATEGORY,'package,:ss]] + ['Join,s,['CATEGORY,'package,:ss]] + fn(a,s) == + isCategoryForm(s,$CategoryFrame) => + s is ["Join",:catlist] => genDomainViewList0(a,rest s) + [genDomainView(a,a,s,"getDomainView")] + [a] + +compDefineCapsuleFunction(df,m,oldE,$prefix,$formalArgList) == + ['DEF,form,originalSignature,specialCases,body] := df + signature := markKillAll originalSignature + $markFreeStack: local := nil --holds "free variables" + $localImportStack : local := nil --local import stack for function + $localDeclareStack: local := nil + $localLoopVariables: local := nil + originalDef := COPY df + [lineNumber,:specialCases] := specialCases + e := oldE + --1. bind global variables + $form: local + $op: local + $functionStats: local:= [0,0] + $argumentConditionList: local + $finalEnv: local + --used by ReplaceExitEtc to get a common environment + $initCapsuleErrorCount: local:= #$semanticErrorStack + $insideCapsuleFunctionIfTrue: local:= true + $CapsuleModemapFrame: local:= e + $CapsuleDomainsInScope: local:= get("$DomainsInScope","special",e) + $insideExpressionIfTrue: local:= true + $returnMode:= m + [$op,:argl]:= form + $form:= [$op,:argl] + argl:= stripOffArgumentConditions argl + $formalArgList:= [:argl,:$formalArgList] + + --let target and local signatures help determine modes of arguments + argModeList:= + identSig:= hasSigInTargetCategory(argl,form,first signature,e) => + (e:= checkAndDeclare(argl,form,identSig,e); rest identSig) + [getArgumentModeOrMoan(a,form,e) for a in argl] + argModeList:= stripOffSubdomainConditions(argModeList,argl) + signature':= [first signature,:argModeList] + if null identSig then --make $op a local function + oldE := put($op,'mode,['Mapping,:signature'],oldE) + + --obtain target type if not given + if null first signature' then signature':= + identSig => identSig + getSignature($op,rest signature',e) or return nil + e:= giveFormalParametersValues(argl,e) + + $signatureOfForm:= signature' --this global is bound in compCapsuleItems + $functionLocations := [[[$op,$signatureOfForm],:lineNumber], + :$functionLocations] + e:= addDomain(first signature',e) + e:= compArgumentConditions e + + if $profileCompiler then + for x in argl for t in rest signature' repeat profileRecord('arguments,x,t) + + + --4. introduce needed domains into extendedEnv + for domain in signature' repeat e:= addDomain(domain,e) + + --6. compile body in environment with extended environment + rettype:= resolve(signature'.target,$returnMode) + + localOrExported := + null member($op,$formalArgList) and + getmode($op,e) is ['Mapping,:.] => 'local + 'exported + + --6a skip if compiling only certain items but not this one + -- could be moved closer to the top + formattedSig := formatUnabbreviated ['Mapping,:signature'] + $compileOnlyCertainItems and _ + not member($op, $compileOnlyCertainItems) => + sayBrightly ['" skipping ", localOrExported,:bright $op] + [nil,['Mapping,:signature'],oldE] + sayBrightly ['" compiling ",localOrExported, + :bright $op,'": ",:formattedSig] +---------------------> new <--------------------------------- + returnType := signature'.target +-- trialT := returnType = "$" and get("Rep",'value,e) and comp(body,'Rep,e) + trialT := returnType = "$" and comp(body,$EmptyMode,e) + ------------------------------------------------------ 11/1/94 + -- try comp-ing in $EmptyMode; if succeed + -- if we succeed then trialT.mode = "$" or "Rep" + -- do a coerce to get the correct result + T := (trialT and coerce(trialT,returnType)) + -------------------------------------- 11/1/94 + or CATCH('compCapsuleBody, compOrCroak(body,returnType,e)) + markChanges(originalDef,T,$signatureOfForm) + [nil,['Mapping,:signature'],oldE] + --------------------------------- + +compCapsuleInner(itemList,m,e) == + e:= addInformation(m,e) + --puts a new 'special' property of $Information + data:= ["PROGN",:itemList] + --RPLACd by compCapsuleItems and Friends + e:= compCapsuleItems(itemList,nil,e) + BOUNDP '$convert2NewCompiler and $convert2NewCompiler => + [nil,m,e] --nonsense but that's fine + localParList:= $functorLocalParameters + if $addForm then data:= ['add,$addForm,data] + code:= + $insideCategoryIfTrue and not $insideCategoryPackageIfTrue => data + processFunctorOrPackage($form,$signature,data,localParList,m,e) + [MKPF([:$getDomainCode,code],"PROGN"),m,e] + +compSingleCapsuleItem(item,$predl,$e) == + $localImportStack : local := nil + $localDeclareStack: local := nil + $markFreeStack: local := nil + newItem := macroExpandInPlace(item,qe(25,$e)) + qe(26,$e) + doIt(newItem, $predl) + qe(27,$e) + $e + +compImport(["import",:doms],m,e) == + for dom in doms repeat + dom := markKillAll dom + markImport dom + e:=addDomain(dom,e) + ["/throwAway",$NoValueMode,e] + +mkUnion(a,b) == + b="$" and $Rep is ["Union",:l] => b + a is ["Union",:l] => + b is ["Union",:l'] => ["Union",:setUnion(l,l')] + member(b, l) => a + ["Union",:setUnion([b],l)] + b is ["Union",:l] => + member(a, l) => b + ["Union",:setUnion([a],l)] + STRINGP a => ["Union",b,a] + ["Union",a,b] + +compForMode(x,m,e) == + $compForModeIfTrue: local:= true + $convert2NewCompiler: local := nil + comp(x,m,e) + +compMakeCategoryObject(c,$e) == + not isCategoryForm(c,$e) => nil + c := markKillAll c + u:= mkEvalableCategoryForm c => [eval markKillAll u,$Category,$e] + nil + +macroExpand(x,e) == --not worked out yet + atom x => (u:= get(x,'macro,e) => macroExpand(u,e); x) + x is ['DEF,lhs,sig,spCases,rhs] => + ['DEF,macroExpand(lhs,e), macroExpandList(sig,e),macroExpandList(spCases,e), + macroExpand(rhs,e)] + x is ['MI,a,b] => + ['MI,a,macroExpand(b,e)] + macroExpandList(x,e) + +getSuccessEnvironment(a,e) == + -- the next four lines try to ensure that explicit special-case tests + -- prevent implicit ones from being generated + a is ["has",x,m] => + x := unLet x + IDENTP x and isDomainForm(m,$EmptyEnvironment) => put(x,"specialCase",m,e) + e + a is ["is",id,m] => + id := unLet id + IDENTP id and isDomainForm(m,$EmptyEnvironment) => + e:=put(id,"specialCase",m,e) + currentProplist:= getProplist(id,e) + [.,.,e] := T := comp(m,$EmptyMode,e) or return nil -- duplicates compIs + newProplist:= consProplistOf(id,currentProplist,"value",removeEnv T) + addBinding(id,newProplist,e) + e + a is ["case",x,m] and (x := unLet x) and IDENTP x => + put(x,"condition",[a,:get(x,"condition",e)],e) + e + +getInverseEnvironment(a,E) == + atom a => E + [op,:argl]:= a +-- the next five lines try to ensure that explicit special-case tests +-- prevent implicit ones from being generated + op="has" => + [x,m]:= argl + x := unLet x + IDENTP x and isDomainForm(m,$EmptyEnvironment) => put(x,"specialCase",m,E) + E + a is ["case",x,m] and (x := unLet x) and IDENTP x => + --the next two lines are necessary to get 3-branched Unions to work + -- old-style unions, that is + if corrupted? get(x,"condition",E) then systemError 'condition + (get(x,"condition",E) is [["OR",:oldpred]]) and member(a,oldpred) => + put(x,"condition",LIST MKPF(delete(a,oldpred),"OR"),E) + getUnionMode(x,E) is ["Union",:l] or systemError 'Union + if corrupted? l then systemError 'list + l':= delete(m,l) + for u in l' repeat + if u is ['_:,=m,:.] then l':= delete(u,l') + newpred:= MKPF([["case",x,m'] for m' in l'],"OR") + put(x,"condition",[newpred,:get(x,"condition",E)],E) + E + +unLet x == + x is ['LET,u,:.] => unLet u + x + +corrupted? u == + u is [op,:r] => + MEMQ(op,'(WI MI PART)) => true + or/[corrupted? x for x in r] + false + +--====================================================================== +-- From apply.boot +--====================================================================== +applyMapping([op,:argl],m,e,ml) == + #argl^=#ml-1 => nil + isCategoryForm(first ml,e) => + --is op a functor? + pairlis:= [[v,:a] for a in argl for v in $FormalMapVariableList] + ml' := SUBLIS(pairlis, ml) + argl':= + [T.expr for x in argl for m' in rest ml'] where + T() == [.,.,e]:= comp(x,m',e) or return "failed" + if argl'="failed" then return nil + form:= [op,:argl'] +---------------------> new <---------------------------- + if constructor? op then form := markKillAll form +---------------------> new <---------------------------- + convert([form,first ml',e],m) + argl':= + [T.expr for x in argl for m' in rest ml] where + T() == [.,.,e]:= comp(x,m',e) or return "failed" + if argl'="failed" then return nil + form:= + not member(op,$formalArgList) and ATOM op and not get(op,'value,e) => + nprefix := $prefix or + -- following needed for referencing local funs at capsule level + getAbbreviation($op,#rest $form) + [op',:argl',"$"] where + op':= INTERN STRCONC(encodeItem nprefix,";",encodeItem op) + ['call,['applyFun,op],:argl'] + pairlis:= [[v,:a] for a in argl' for v in $FormalMapVariableList] + convert([form,SUBLIS(pairlis,first ml),e],m) + +compFormWithModemap(form,m,e,modemap) == + compFormWithModemap1(form,m,e,modemap,true) or compFormWithModemap1(form,m,e,modemap,false) + +compFormWithModemap1(form,m,e,modemap,Rep2Dollar?) == + [op,:argl] := form := markKillExpr form + [[dc,:.],:.] := modemap +----------> new: <----------- + if Rep2Dollar? then + if dc = 'Rep then + modemap := SUBST('Rep,'_$,modemap) + m := SUBST('Rep,'_$,m) + else return nil +----------> new: <----------- + [map:= [.,target,:.],[pred,impl]]:= modemap + -- this fails if the subsuming modemap is conditional + --impl is ['Subsumed,:.] => nil + if isCategoryForm(target,e) and isFunctor op then + [modemap,e]:= substituteIntoFunctorModemap(argl,modemap,e) or return nil + [map:= [.,target,:.],:cexpr]:= modemap + sv:=listOfSharpVars map + if sv then + -- SAY [ "compiling ", op, " in compFormWithModemap, + -- mode= ",map," sharp vars=",sv] + for x in argl for ss in $FormalMapVariableList repeat + if ss in sv then + [map:= [.,target,:.],:cexpr]:= modemap :=SUBST(x,ss,modemap) + -- SAY ["new map is",map] + not (target':= coerceable(target,m,e)) => nil + markMap := map + map:= [target',:rest map] + [f,Tl,sl]:= compApplyModemap(form,modemap,e,nil) or return nil + + --generate code; return + T:= + e':= + Tl => (LAST Tl).env + e + [x',m',e'] where + m':= SUBLIS(sl,map.(1)) + x':= + form':= [f,:[t.expr for t in Tl]] + m'=$Category or isCategoryForm(m',e) => form' + -- try to deal with new-style Unions where we know the conditions + op = "elt" and f is ['XLAM,:.] and IDENTP(z:=CAR argl) and + (c:=get(z,'condition,e)) and + c is [['case,=z,c1]] and + (c1 is ['_:,=(CADR argl),=m] or EQ(c1,CADR argl) ) => +-- first is a full tag, as placed by getInverseEnvironment +-- second is what getSuccessEnvironment will place there + ["CDR",z] + markTran(form,form',markMap,e') + qt(18,T) + convert(T,m) + +convert(T,m) == + tcheck T + qe(23,T.env) + coerce(T,resolve(T.mode,m) or return nil) + +compElt(origForm,m,E) == + form := markKillAll origForm + form isnt ["elt",aDomain,anOp] => compForm(origForm,m,E) + aDomain="Lisp" => + markLisp([anOp',m,E],E)where anOp'() == (anOp=$Zero => 0; anOp=$One => 1; anOp) + isDomainForm(aDomain,E) => + markImport opOf aDomain + E:= addDomain(aDomain,E) + mmList:= getModemapListFromDomain(anOp,0,aDomain,E) + modemap:= + n:=#mmList + 1=n => mmList.(0) + 0=n => + return + stackMessage ['"Operation ","%b",anOp,"%d", + '"missing from domain: ", aDomain] + stackWarning ['"more than 1 modemap for: ",anOp, + '" with dc=",aDomain,'" ===>" + ,mmList] + mmList.(0) +----------> new: <----------- + if aDomain = 'Rep then + modemap := SUBST('Rep,'_$,modemap) + m := SUBST('Rep,'_$,m) +----------> new: <----------- + [sig,[pred,val]]:= modemap + #sig^=2 and ^val is ["elt",:.] => nil --what does the second clause do ???? +--+ + val := genDeltaEntry [opOf anOp,:modemap] + x := markTran(origForm,[val],sig,[E]) + [x,first rest sig,E] --implies fn calls used to access constants + compForm(origForm,m,E) + +pause op == op +compApplyModemap(form,modemap,$e,sl) == + [op,:argl] := form --form to be compiled + [[mc,mr,:margl],:fnsel] := modemap --modemap we are testing + + -- $e is the current environment + -- sl substitution list, nil means bottom-up, otherwise top-down + + -- 0. fail immediately if #argl=#margl + + if #argl^=#margl then return nil + + -- 1. use modemap to evaluate arguments, returning failed if + -- not possible + + lt:= + [[.,m',$e]:= + comp(y,g,$e) or return "failed" where + g:= SUBLIS(sl,m) where + sl:= pmatchWithSl(m',m,sl) for y in argl for m in margl] + lt="failed" => return nil + + -- 2. coerce each argument to final domain, returning failed + -- if not possible + + lt':= [coerce(y,d) or return "failed" + for y in lt for d in SUBLIS(sl,margl)] + lt'="failed" => return nil + + -- 3. obtain domain-specific function, if possible, and return + + --$bindings is bound by compMapCond + [f,$bindings]:= compMapCond(op,mc,sl,fnsel) or return nil + +--+ can no longer trust what the modemap says for a reference into +--+ an exterior domain (it is calculating the displacement based on view +--+ information which is no longer valid; thus ignore this index and +--+ store the signature instead. + +--$NRTflag=true and f is [op1,d,.] and NE(d,'$) and member(op1,'(ELT CONST)) => + f is [op1,d,.] and member(op1,'(ELT CONST Subsumed)) => + [genDeltaEntry [op,:modemap],lt',$bindings] + markImport mc + [f,lt',$bindings] + +compMapCond''(cexpr,dc) == + cexpr=true => true + --cexpr = "true" => true +---------------> new <---------------------- + cexpr is [op,:l] and MEMQ(op,'(_and AND)) => and/[compMapCond''(u,dc) for u in l] + cexpr is [op,:l] and MEMQ(op,'(_or OR)) => or/[compMapCond''(u,dc) for u in l] +---------------> new <---------------------- + cexpr is ["not",u] => not compMapCond''(u,dc) + cexpr is ["has",name,cat] => (knownInfo cexpr => true; false) + --for the time being we'll stop here - shouldn't happen so far + --$disregardConditionIfTrue => true + --stackSemanticError(("not known that",'%b,name, + -- '%d,"has",'%b,cat,'%d),nil) + --now it must be an attribute + member(["ATTRIBUTE",dc,cexpr],get("$Information","special",$e)) => true + --for the time being we'll stop here - shouldn't happen so far + stackMessage ["not known that",'%b,dc,'%d,"has",'%b,cexpr,'%d] + false + +--====================================================================== +-- From nruncomp.boot +--====================================================================== +NRTgetLocalIndex1(item,killBindingIfTrue) == + k := NRTassocIndex item => k + item = $NRTaddForm => 5 + item = '$ => 0 + item = '_$_$ => 2 + value:= + MEMQ(item,$formalArgList) => item + nil + atom item and null MEMQ(item,'($ _$_$)) + and null value => --give slots to atoms + $NRTdeltaList:= [['domain,NRTaddInner item,:value],:$NRTdeltaList] + $NRTdeltaListComp:=[item,:$NRTdeltaListComp] + $NRTdeltaLength := $NRTdeltaLength+1 + $NRTbase + $NRTdeltaLength - 1 + $NRTdeltaList:= [['domain,NRTaddInner item,:value],:$NRTdeltaList] + saveNRTdeltaListComp:= $NRTdeltaListComp:=[nil,:$NRTdeltaListComp] + saveIndex := $NRTbase + $NRTdeltaLength + $NRTdeltaLength := $NRTdeltaLength+1 + compEntry:= item + ----94/11/07 + -- WAS: compOrCroak(item,$EmptyMode,$e).expr + RPLACA(saveNRTdeltaListComp,compEntry) + saveIndex + +optDeltaEntry(op,sig,dc,eltOrConst) == + return nil --------> kill it + $killOptimizeIfTrue = true => nil + ndc := + dc = '$ => $functorForm + atom dc and (dcval := get(dc,'value,$e)) => dcval.expr + dc +--if (atom dc) and (dcval := get(dc,'value,$e)) +-- then ndc := dcval.expr +-- else ndc := dc + sig := SUBST(ndc,dc,sig) + not MEMQ(KAR ndc,$optimizableConstructorNames) => nil + dcval := optCallEval ndc + -- MSUBST guarantees to use EQUAL testing + sig := MSUBST(devaluate dcval, ndc, sig) + if rest ndc then + for new in rest devaluate dcval for old in rest ndc repeat + sig := MSUBST(new,old,sig) + -- optCallEval sends (List X) to (LIst (Integer)) etc, + -- so we should make the same transformation + fn := compiledLookup(op,sig,dcval) + if null fn then + -- following code is to handle selectors like first, rest + nsig := [quoteSelector tt for tt in sig] where + quoteSelector(x) == + not(IDENTP x) => x + get(x,'value,$e) => x + x='$ => x + MKQ x + fn := compiledLookup(op,nsig,dcval) + if null fn then return nil + eltOrConst="CONST" => + hehe fn + [op] -----------> return just the op here +-- ['XLAM,'ignore,MKQ SPADCALL fn] + GETL(compileTimeBindingOf first fn,'SPADreplace) + +genDeltaEntry opMmPair == +--called from compApplyModemap +--$NRTdeltaLength=0.. always equals length of $NRTdeltaList + [.,[odc,:.],.] := opMmPair + --opModemapPair := SUBLIS($LocalDomainAlist,opMmPair) + [op,[dc,:sig],[.,cform:=[eltOrConst,:.]]] := opMmPair + if $profileCompiler = true then + profileRecord(dc,op,sig) +-- markImport dc + eltOrConst = 'XLAM => cform + if eltOrConst = 'Subsumed then eltOrConst := 'ELT + -- following hack needed to invert Rep to $ substitution + if odc = 'Rep and cform is [.,.,osig] then sig:=osig + newimp := optDeltaEntry(op,sig,dc,eltOrConst) => newimp + setDifference(listOfBoundVars dc,$functorLocalParameters) ^= [] => + ['applyFun,['compiledLookupCheck,MKQ op, + mkList consSig(sig,dc),consDomainForm(dc,nil)]] + --if null atom dc then + -- sig := substitute('$,dc,sig) + -- cform := substitute('$,dc,cform) + opModemapPair := + [op,[dc,:[genDeltaSig x for x in sig]],['T,cform]] -- force pred to T + if null NRTassocIndex dc and dc ^= $NRTaddForm and + (member(dc,$functorLocalParameters) or null atom dc) then + --create "domain" entry to $NRTdeltaList + $NRTdeltaList:= [['domain,NRTaddInner dc,:dc],:$NRTdeltaList] + saveNRTdeltaListComp:= $NRTdeltaListComp:=[nil,:$NRTdeltaListComp] + $NRTdeltaLength := $NRTdeltaLength+1 + compEntry:= + dc + RPLACA(saveNRTdeltaListComp,compEntry) + chk(saveNRTdeltaListComp,102) + u := + [eltOrConst,'$,$NRTbase+$NRTdeltaLength-index] where index() == + (n:= POSN1(opModemapPair,$NRTdeltaList)) => n + 1 + --n + 1 since $NRTdeltaLength is 1 too large + $NRTdeltaList:= [opModemapPair,:$NRTdeltaList] + $NRTdeltaListComp:=[nil,:$NRTdeltaListComp] + $NRTdeltaLength := $NRTdeltaLength+1 + 0 + u + +--====================================================================== +-- From nruncomp.boot +--====================================================================== +parseIf t == + t isnt [p,a,b] => t + ifTran(parseTran p,parseTran a,parseTran b) where + ifTran(p,a,b) == + null($InteractiveMode) and p='true => a + null($InteractiveMode) and p='false => b + p is ['not,p'] => ifTran(p',b,a) + p is ['IF,p',a',b'] => ifTran(p',ifTran(a',COPY a,COPY b),ifTran(b',a,b)) + p is ['SEQ,:l,['exit,1,p']] => + ['SEQ,:l,['exit,1,ifTran(p',incExitLevel a,incExitLevel b)]] + --this assumes that l has no exits + a is ['IF, =p,a',.] => ['IF,p,a',b] + b is ['IF, =p,.,b'] => ['IF,p,a,b'] +-- makeSimplePredicateOrNil p is ['SEQ,:s,['exit,1,val]] => +-- parseTran ['SEQ,:s,['exit,1,incExitLevel ['IF,val,a,b]]] + ['IF,p,a,b] + +--====================================================================== +-- From parse.boot +--====================================================================== +parseNot u == ['not,parseTran first u] + +makeSimplePredicateOrNil p == nil + +--====================================================================== +-- From g-cndata.boot +--====================================================================== +mkUserConstructorAbbreviation(c,a,type) == + if $AnalyzeOnly or $convert2NewCompiler then + $abbreviationStack := [[type,a,:c],:$abbreviationStack] + if not atom c then c:= CAR c -- Existing constructors will be wrapped + constructorAbbreviationErrorCheck(c,a,type,'abbreviationError) + clearClams() + clearConstructorCache(c) + installConstructor(c,type) + setAutoLoadProperty(c) + +--====================================================================== +-- From iterator.boot +--====================================================================== + +compreduce(form is [.,op,x],m,e) == + T := compForm(form,m,e) or return nil + y := T.expr + RPLACA(y,"REDUCE") + ------------------<== distinquish this as the special reduce form + (y is ["REDUCE",:.]) and (id:= getIdentity(op,e)) and (u := comp0(id,m,e)) and + # getNumberTypesInScope() > 1 => markSimpleReduce([:y, ["@",u.expr,m]], T) + T + +compReduce1(form is ["REDUCE",op,.,collectForm],m,e,$formalArgList) == +-------------------------------> 11/28 all new to preserve collect forms + markImport m + [collectOp,:itl,body]:= collectForm + $e:= e + itl:= [([.,$e]:= compIterator(x,$e) or return "failed").(0) for x in itl] + itl="failed" => return nil + e:= $e + T0 := comp0(body,m,e) or return nil + md := T0.mode + T1 := compOrCroak(collectForm,["List",md],e) + T := [["REDUCE",op,nil,T1.expr],md,T1.env] + markReduce(form,T) + +compIterator(it,e) == + it is ["IN",x,y] => + --these two lines must be in this order, to get "for f in list f" + --to give an error message if f is undefined + ---------------> new <--------------------- + [y',m,e] := markInValue(y, e) + x := markKillAll x + ------------------ + $formalArgList:= [x,:$formalArgList] + [.,mUnder]:= + modeIsAggregateOf("List",m,e) or modeIsAggregateOf("Vector",m,e) or return + stackMessage ["mode: ",m," must be a list or vector of some mode"] + if null get(x,"mode",e) then [.,.,e]:= + compMakeDeclaration([":",x,mUnder],$EmptyMode,e) or return nil + e:= put(x,"value",[genSomeVariable(),mUnder,e],e) + markReduceIn(it, [["IN",x,y'],e]) + it is ["ON",x,y] => +---------------> new <--------------------- + x := markKillAll x + ------------------ + $formalArgList:= [x,:$formalArgList] + y := markKillAll y + markImport m +---------------> new <--------------------- + [y',m,e]:= comp(y,$EmptyMode,e) or return nil + [.,mUnder]:= + modeIsAggregateOf("List",m,e) or return + stackMessage ["mode: ",m," must be a list of other modes"] + if null get(x,"mode",e) then [.,.,e]:= + compMakeDeclaration([":",x,m],$EmptyMode,e) or return nil + e:= put(x,"value",[genSomeVariable(),m,e],e) + [["ON",x,y'],e] + it is ["STEP",oindex,start,inc,:optFinal] => + index := markKillAll oindex + $formalArgList:= [index,:$formalArgList] + --if all start/inc/end compile as small integers, then loop + --is compiled as a small integer loop + final':= nil +---------------> new <--------------------- + u := smallIntegerStep(it,index,start,inc,optFinal,e) => u +---------------> new <--------------------- + [start,.,e]:= + comp(markKillAll start,$Integer,e) or return + stackMessage ["start value of index: ",start," must be an integer"] + [inc,.,e]:= + comp(markKillAll inc,$Integer,e) or return + stackMessage ["index increment:",inc," must be an integer"] + if optFinal is [final] then + [final,.,e]:= + comp(markKillAll final,$Integer,e) or return + stackMessage ["final value of index: ",final," must be an integer"] + optFinal:= [final] + indexmode:= + comp(CADDR it,$NonNegativeInteger,e) => $NonNegativeInteger + $Integer +-- markImport ['Segment,indexmode] + if null get(index,"mode",e) then [.,.,e]:= + compMakeDeclaration([":",index,indexmode],$EmptyMode,e) or return nil + e:= put(index,"value",[genSomeVariable(),indexmode,e],e) + markReduceStep(it, [["STEP",markStep(index),start,inc,:optFinal],e]) + it is ["WHILE",p] => + [p',m,e]:= + comp(p,$Boolean,e) or return + stackMessage ["WHILE operand: ",p," is not Boolean valued"] + markReduceWhile(it, [["WHILE",p'],e]) + it is ["UNTIL",p] => markReduceUntil(it, ($until:= p; ['$until,e])) + it is ["|",x] => + u:= + comp(x,$Boolean,e) or return + stackMessage ["SUCHTHAT operand: ",x," is not Boolean value"] + markReduceSuchthat(it, [["|",u.expr],u.env]) + nil + +smallIntegerStep(it,index,start,inc,optFinal,e) == + start := markKillAll start + inc := markKillAll inc + optFinal := markKillAll optFinal + startNum := source2Number start + incNum := source2Number inc + mode := get(index,"mode",e) +--fail if +----> a) index has a mode that is not $SmallInteger +----> b) one of start,inc, final won't comp as a $SmallInteger + mode and mode ^= $SmallInteger => nil + null (start':= comp(start,$SmallInteger,e)) => nil + null (inc':= comp(inc,$SmallInteger,start'.env)) => nil + if optFinal is [final] and not (final':= comp(final,$SmallInteger,inc'.env)) then +-- not (FIXP startNum and FIXP incNum) => return nil +-- null FIXP startNum or ABSVAL startNum > 100 => return nil + -----> assume that optFinal is $SmallInteger + T := comp(final,$EmptyMode,inc'.env) or return nil + final' := T + maxSuperType(T.mode,e) ^= $Integer => return nil + givenRange := T.mode + indexmode:= $SmallInteger + [.,.,e]:= compMakeDeclaration([":",index,indexmode],$EmptyMode, + (final' => final'.env; inc'.env)) or return nil + range := + FIXP startNum and FIXP incNum => + startNum > 0 and incNum > 0 => $PositiveInteger + startNum < 0 and incNum < 0 => $NegativeInteger + incNum > 0 => $NonNegativeInteger --startNum = 0 + $NonPositiveInteger + givenRange => givenRange + nil + e:= put(index,"range",range,e) + e:= put(index,"value",[genSomeVariable(),indexmode,e],e) + noptFinal := + final' => + [final'.expr] + nil + [markStepSI(it,["ISTEP",index,start'.expr,inc'.expr,:noptFinal]),e] + +source2Number n == + n := markKillAll n + n = $Zero => 0 + n = $One => 1 + n + +compRepeatOrCollect(form,m,e) == + fn(form,[m,:$exitModeStack],[#$exitModeStack,:$leaveLevelStack],$formalArgList + ,e) where + fn(form,$exitModeStack,$leaveLevelStack,$formalArgList,e) == + $until: local + [repeatOrCollect,:itl,body]:= form + itl':= + [([x',e]:= compIterator(x,e) or return "failed"; x') for x in itl] + itl'="failed" => nil + targetMode:= first $exitModeStack +-- pp '"---------" +-- pp targetMode + bodyMode:= + repeatOrCollect="COLLECT" => + targetMode = '$EmptyMode => '$EmptyMode + (u:=modeIsAggregateOf('List,targetMode,e)) => + CADR u + (u:=modeIsAggregateOf('Vector,targetMode,e)) => + repeatOrCollect:='COLLECTV + CADR u + stackMessage('"Invalid collect bodytype") + return nil + -- If we're doing a collect, and the type isn't conformable + -- then we've boobed. JHD 26.July.1990 + $NoValueMode + [body',m',e']:= T := + -- (m1:= listOrVectorElementMode targetMode) and comp(body,m1,e) or + compOrCroak(body,bodyMode,e) or return nil + markRepeatBody(body, T) + if $until then + [untilCode,.,e']:= comp($until,$Boolean,e') + itl':= substitute(["UNTIL",untilCode],'$until,itl') + form':= [repeatOrCollect,:itl',body'] + m'':= + repeatOrCollect="COLLECT" => + (u:=modeIsAggregateOf('List,targetMode,e)) => CAR u + ["List",m'] + repeatOrCollect="COLLECTV" => + (u:=modeIsAggregateOf('Vector,targetMode,e)) => CAR u + ["Vector",m'] + m' +--------> new <-------------- + markImport m'' +--------> new <-------------- + markRepeat(form,coerceExit([form',m'',e'],targetMode)) + +chaseInferences(origPred,$e) == + pred := markKillAll origPred + ----------------------------12/4/94 do this immediately + foo hasToInfo pred where + foo pred == + knownInfo pred => nil + $e:= actOnInfo(pred,$e) + pred:= infoToHas pred + for u in get("$Information","special",$e) repeat + u is ["COND",:l] => + for [ante,:conseq] in l repeat + ante=pred => [foo w for w in conseq] + ante is ["and",:ante'] and member(pred,ante') => + ante':= delete(pred,ante') + v':= + LENGTH ante'=1 => first ante' + ["and",:ante'] + v':= ["COND",[v',:conseq]] + member(v',get("$Information","special",$e)) => nil + $e:= + put("$Information","special",[v',: + get("$Information","special",$e)],$e) + nil + $e + +--====================================================================== +-- doit Code +--====================================================================== +doIt(item,$predl) == + $GENNO: local:= 0 + $coerceList: local := nil + ---> + if item is ['PART,.,a] then item := a + ------------------------------------- + item is ['SEQ,:.] => doItSeq item + isDomainForm(item,$e) => doItDomain item + item is ['LET,:.] => doItLet item + item is [":",a,t] => [.,.,$e]:= + markDeclaredImport markKillAll t + compOrCroak(item,$EmptyMode,$e) + item is ['import,:doms] => + item := ['import,:(doms := markKillAll doms)] + for dom in doms repeat + sayBrightly ['" importing ",:formatUnabbreviated dom] + [.,.,$e] := compOrCroak(item,$EmptyMode,$e) + wiReplaceNode(item,'(PROGN),10) + item is ["IF",:.] => doItIf(item,$predl,$e) + item is ["where",b,:l] => compOrCroak(item,$EmptyMode,$e) + item is ["MDEF",:.] => [.,.,$e]:= compOrCroak(item,$EmptyMode,$e) + item is ['DEF,:.] => doItDef item + T:= compOrCroak(item,$EmptyMode,$e) => doItExpression(item,T) + true => cannotDo() + +holdIt item == item + +doItIf(item is [.,p,x,y],$predl,$e) == + olde:= $e + [p',.,$e]:= qt(19,comp(p,$Boolean,$e)) or userError ['"not a Boolean:",p] + oldFLP:=$functorLocalParameters + if x^="noBranch" then +--> new <----------------------- + qe(20,compSingleCapsuleItem(x,[p,:$predl],getSuccessEnvironment(markKillAll p,$e))) +---> new ----------- + x':=localExtras(oldFLP) + where localExtras(oldFLP) == + EQ(oldFLP,$functorLocalParameters) => NIL + flp1:=$functorLocalParameters + oldFLP':=oldFLP + n:=0 + while oldFLP' repeat + oldFLP':=CDR oldFLP' + flp1:=CDR flp1 + n:=n+1 + -- Now we have to add code to compile all the elements + -- of functorLocalParameters that were added during the + -- conditional compilation + nils:=ans:=[] + for u in flp1 repeat -- is =u form always an ATOM? + if ATOM u or (or/[v is [.,=u,:.] for v in $getDomainCode]) + then + nils:=[u,:nils] + else + gv := GENSYM() + ans:=[['LET,gv,u],:ans] + nils:=[gv,:nils] + n:=n+1 + + $functorLocalParameters:=[:oldFLP,:REVERSE nils] + REVERSE ans + oldFLP:=$functorLocalParameters + if y^="noBranch" then +--> new <----------------------- + qe(21,compSingleCapsuleItem(y,[['not, p],:$predl],getInverseEnvironment(markKillAll p,olde))) +--> ----------- + y':=localExtras(oldFLP) + wiReplaceNode(item,["COND",[p',x,:x'],['(QUOTE T),y,:y']],12) + +doItSeq item == + ['SEQ,:l,['exit,1,x]] := item + RPLACA(item,"PROGN") + RPLACA(LASTNODE item,x) + for it1 in rest item repeat $e:= compSingleCapsuleItem(it1,$predl,$e) + +doItDomain item == + -- convert naked top level domains to import + u:= ['import, [first item,:rest item]] + markImport CADR u + stackWarning ["Use: import ", [first item,:rest item]] +--wiReplaceNode(item, u, 14) + RPLACA(item, first u) + RPLACD(item, rest u) + doIt(item,$predl) + +doItLet item == + qe(3,$e) + res := doItLet1 item + qe(4,$e) + res + +doItLet1 item == + ['LET,lhs,rhs,:.] := item + not (compOrCroak(item,$EmptyMode,$e) is [code,.,$e]) => + stackSemanticError(["cannot compile assigned value to",:bright lhs],nil) + qe(5,$e) + code := markKillAll code + not (code is ['LET,lhs',rhs',:.] and atom lhs') => + code is ["PROGN",:.] => + stackSemanticError(["multiple assignment ",item," not allowed"],nil) + wiReplaceNode(item, code, 24) + lhs:= lhs' + if not member(KAR rhs,$NonMentionableDomainNames) and + not MEMQ(lhs, $functorLocalParameters) then + $functorLocalParameters:= [:$functorLocalParameters,lhs] + if (rhs' := rhsOfLetIsDomainForm code) then + if isFunctor rhs' then + $functorsUsed:= insert(opOf rhs',$functorsUsed) + $packagesUsed:= insert([opOf rhs'],$packagesUsed) + $globalImportDefAlist := pp [[lhs, :rhs'],:$globalImportDefAlist] + if lhs="Rep" then + $Representation:= (get("Rep",'value,$e)).(0) + --$Representation bound by compDefineFunctor, used in compNoStacking +--+ + if $NRTopt = true + then NRTgetLocalIndex $Representation +--+ + $LocalDomainAlist:= --see genDeltaEntry + [[lhs,:SUBLIS($LocalDomainAlist,get(lhs,'value,$e).0)],:$LocalDomainAlist] +--+ + qe(6,$e) + code is ['LET,:.] => + rhsCode:= rhs' + op := ($QuickCode => 'QSETREFV;'SETELT) + wiReplaceNode(item,[op,'$,NRTgetLocalIndexClear lhs,rhsCode], 16) + wiReplaceNode(item, code, 18) + +rhsOfLetIsDomainForm code == + code is ['LET,.,rhs',:.] => + isDomainForm(rhs',$e) => rhs' + isDomainForm(rhs' := markKillAll rhs',$e) => rhs' + false + false + +doItDef item == + ['DEF,[op,:.],:.] := item + body:= isMacro(item,$e) => $e:= put(op,'macro,body,$e) + [.,.,$e]:= t:= compOrCroak(item,$EmptyMode,$e) + chk(item,3) + RPLACA(item,"CodeDefine") + --Note that DescendCode, in CodeDefine, is looking for this + RPLACD(CADR item,[$signatureOfForm]) + chk(item,4) + --This is how the signature is updated for buildFunctor to recognise +--+ + functionPart:= ['dispatchFunction,t.expr] + wiReplaceNode(CDDR item,[functionPart], 20) + chk(item, 30) + +doItExpression(item,T) == + SETQ($ITEM,COPY item) + SETQ($T1,COPY T.expr) + chk(T.expr, 304) + u := markCapsuleExpression(item, T) + [code,.,$e]:= u + wiReplaceNode(item,code, 22) + +wiReplaceNode(node,ocode,key) == + ncode := CONS(first ocode, rest ocode) + code := replaceNodeInStructureBy(node,ncode) + SETQ($NODE,COPY node) + SETQ($NODE1, COPY first code) + SETQ($NODE2, COPY rest code) + RPLACA(node,first code) + RPLACD(node,rest code) + chk(code, key) + chk(node, key + 1) + +replaceNodeInStructureBy(node, x) == + $nodeCopy: local := [CAR node,:CDR node] + replaceNodeBy(node, x) + node + +replaceNodeBy(node, x) == + atom x => nil + for y in tails x | EQCAR(x,node) repeat RPLAC(CAR x, $nodeCopy) + nil + +chk(x,key) == fn(x,0,key) where fn(x,cnt,key) == + cnt > 10000 => + sayBrightly ["--> ", key, " <---"] + hahaha(key) + atom x => cnt + VECP x => systemError nil + for y in x repeat cnt := fn(y, cnt + 1, key) + cnt + diff --git a/src/interp/wi2.boot.pamphlet b/src/interp/wi2.boot.pamphlet deleted file mode 100644 index e4dd5a8a..00000000 --- a/src/interp/wi2.boot.pamphlet +++ /dev/null @@ -1,1255 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/wi2.boot} Pamphlet} -\author{The Axiom Team} - -\begin{document} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\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" - -compDefineFunctor1(df, m,$e,$prefix,$formalArgList) == - ['DEF,form,signature,$functorSpecialCases,body] := df - signature := markKillAll signature - if NRTPARSE = true then - [lineNumber,:$functorSpecialCases] := $functorSpecialCases --- 1. bind global variables - $addForm: local - $viewNames: local:= nil - - --This list is only used in genDomainViewName, for generating names - --for alternate views, if they do not already exist. - --format: Alist: (domain name . sublist) - --sublist is alist: category . name of view - $functionStats: local:= [0,0] - $functorStats: local:= [0,0] - $DEFdepth : local := 0 --for conversion to new compiler 3/93 - $capsuleStack : local := nil --for conversion to new compiler 3/93 - $predicateStack:local := nil --for conversion to new compiler 3/93 - $signatureStack:local := nil --for conversion to new compiler 3/93 - $importStack : local := nil --for conversion to new compiler 3/93 - $globalImportStack : local := nil --for conversion to new compiler 3/93 - $globalDeclareStack : local := nil - $globalImportDefAlist: local:= nil - $localMacroStack : local := nil --for conversion to new compiler 3/93 - $freeStack : local := nil --for conversion to new compiler 3/93 - $domainLevelVariableList: local := nil--for conversion to new compiler 3/93 - $localLoopVariables: local := nil - $pathStack : local := nil - $form: local - $op: local - $signature: local - $functorTarget: local - $Representation: local - --Set in doIt, accessed in the compiler - compNoStacking - $LocalDomainAlist: local --set in doIt, accessed in genDeltaEntry - $LocalDomainAlist:= nil - $functorForm: local - $functorLocalParameters: local - $CheckVectorList: local - --prevents CheckVector from printing out same message twice - $getDomainCode: local -- code for getting views - $insideFunctorIfTrue: local:= true - $functorsUsed: local --not currently used, finds dependent functors - $setelt: local := - $QuickCode = true => 'QSETREFV - 'SETELT - $TOP__LEVEL: local - $genSDVar: local:= 0 - originale:= $e - [$op,:argl]:= form - $formalArgList:= [:argl,:$formalArgList] - $pairlis := [[a,:v] for a in argl for v in $FormalMapVariableList] - $mutableDomain: local := - -- all defaulting packages should have caching turned off - isCategoryPackageName $op or - (if BOUNDP '$mutableDomains then MEMQ($op,$mutableDomains) - else false ) --true if domain has mutable state - signature':= - [first signature,:[getArgumentModeOrMoan(a,form,$e) for a in argl]] - $functorForm:= $form:= [$op,:argl] - $globalImportStack := - [markKillAll x for x in rest $functorForm for typ in rest signature' - | GETDATABASE(opOf typ,'CONSTRUCTORKIND) = 'category] - if null first signature' then signature':= - modemap2Signature getModemap($form,$e) - target:= first signature' - $functorTarget:= target - $e:= giveFormalParametersValues(argl,$e) - [ds,.,$e]:= compMakeCategoryObject(target,$e) or ---+ copy needed since slot1 is reset; compMake.. can return a cached vector - sayBrightly '" cannot produce category object:" - pp target - return nil - $domainShell:= COPY_-SEQ ds - $attributesName:local := INTERN STRCONC(PNAME $op,'";attributes") - attributeList := ds.2 --see below under "loadTimeAlist" ---+ 7 lines for $NRT follow - $goGetList: local := nil --->--these globals used by NRTmakeCategoryAlist, set by NRTsetVector4Part1 - $condAlist: local := nil - $uncondAlist: local := nil --->>-- next global initialized here, reset by NRTbuildFunctor - $NRTslot1PredicateList: local := - REMDUP [CADR x for x in attributeList] --->>-- next global initialized here, used by NRTgenAttributeAlist (NRUNOPT) - $NRTattributeAlist: local := NRTgenInitialAttributeAlist attributeList - $NRTslot1Info: local --set in NRTmakeSlot1 called by NRTbuildFunctor - --this is used below to set $lisplibSlot1 global - $NRTbase: local := 6 -- equals length of $domainShell - $NRTaddForm: local := nil -- see compAdd; NRTmakeSlot1 - $NRTdeltaList: local := nil --list of misc. elts used in compiled fncts - $NRTdeltaListComp: local := nil --list of COMP-ed forms for $NRTdeltaList - $NRTaddList: local := nil --list of fncts not defined in capsule (added) - $NRTdeltaLength: local := 0 -- =length of block of extra entries in vector - $NRTloadTimeAlist: local := nil --used for things in slot4 (NRTsetVector4) - $NRTdomainFormList: local := nil -- of form ((gensym . (Repe...)) ... - -- the above optimizes the calls to local domains - $template: local:= nil --stored in the lisplib (if $NRTvec = true) - $functionLocations: local := nil --locations of defined functions in source - -- generate slots for arguments first, then for $NRTaddForm in compAdd - for x in argl repeat NRTgetLocalIndex x - [.,.,$e]:= compMakeDeclaration([":",'_$,target],m,$e) - --The following loop sees if we can economise on ADDed operations - --by using those of Rep, if that is the same. Example: DIRPROD - if $insideCategoryPackageIfTrue^= true then - if body is ['add,ab:=[fn,:.],['CAPSULE,:cb]] and MEMQ(fn,'(List Vector)) - and FindRep(cb) = ab - where FindRep cb == - u:= - while cb repeat - ATOM cb => return nil - cb is [['LET,'Rep,v,:.],:.] => return (u:=v) - cb:=CDR cb - u - then $e:= augModemapsFromCategoryRep('_$,ab,cb,target,$e) - else $e:= augModemapsFromCategory('_$,'_$,'_$,target,$e) - $signature:= signature' - operationAlist:= SUBLIS($pairlis,$domainShell.(1)) - parSignature:= SUBLIS($pairlis,signature') - parForm:= SUBLIS($pairlis,form) - --- (3.1) now make a list of the functor's local parameters; for --- domain D in argl,check its signature: if domain, its type is Join(A1,..,An); --- in this case, D is replaced by D1,..,Dn (gensyms) which are set --- to the A1,..,An view of D - if isPackageFunction() then $functorLocalParameters:= - [nil,: - [nil - for i in 6..MAXINDEX $domainShell | - $domainShell.i is [.,.,['ELT,'_$,.]]]] - --leave space for vector ops and package name to be stored ---+ - $functorLocalParameters:= - argPars := - makeFunctorArgumentParameters(argl,rest signature',first signature') - -- must do above to bring categories into scope --see line 5 of genDomainView - argl --- 4. compile body in environment of %type declarations for arguments - op':= $op - rettype:= signature'.target - SETQ($myFunctorBody, body) --------> new <-------- - T:= compFunctorBody(body,rettype,$e,parForm) ----------------> new <--------------------- - BOUNDP '$convert2NewCompiler and $convert2NewCompiler => - return markFinish($originalBody,[$form,['Mapping,:signature'],T.env]) ----------------> new <--------------------- - -- If only compiling certain items, then ignore the body shell. - $compileOnlyCertainItems => - reportOnFunctorCompilation() - [nil, ['Mapping, :signature'], originale] - - body':= T.expr - lamOrSlam:= if $mutableDomain then 'LAM else 'SPADSLAM - fun:= compile SUBLIS($pairlis, [op',[lamOrSlam,argl,body']]) - --The above statement stops substitutions gettting in one another's way ---+ - operationAlist := SUBLIS($pairlis,$lisplibOperationAlist) - if $LISPLIB then - augmentLisplibModemapsFromFunctor(parForm,operationAlist,parSignature) - reportOnFunctorCompilation() - --- 5. give operator a 'modemap property --- if $functorsUsed then MAKEPROP(op',"NEEDS",$functorsUsed) - $insideFunctorIfTrue:= false - if $LISPLIB then - $lisplibKind:= - $functorTarget is ["CATEGORY",key,:.] and key^="domain" => 'package - 'domain - $lisplibForm:= form - modemap:= [[parForm,:parSignature],[true,op']] - $lisplibModemap:= modemap - if null $bootStrapMode then - $NRTslot1Info := NRTmakeSlot1Info() - $isOpPackageName: local := isCategoryPackageName $op - if $isOpPackageName then lisplibWrite('"slot1DataBase", - ['updateSlot1DataBase,MKQ $NRTslot1Info],$libFile) - $lisplibFunctionLocations := SUBLIS($pairlis,$functionLocations) - $lisplibCategoriesExtended := SUBLIS($pairlis,$lisplibCategoriesExtended) - -- see NRTsetVector4 for initial setting of $lisplibCategoriesExtended - libFn := getConstructorAbbreviation op' - $lookupFunction: local := - NRTgetLookupFunction($functorForm,CADAR $lisplibModemap,$NRTaddForm) - --either lookupComplete (for forgetful guys) or lookupIncomplete - $byteAddress :local := 0 - $byteVec :local := nil - $NRTslot1PredicateList := - [simpBool x for x in $NRTslot1PredicateList] - rwriteLispForm('loadTimeStuff, - ['MAKEPROP,MKQ $op,''infovec,getInfovecCode()]) - $lisplibSlot1 := $NRTslot1Info --NIL or set by $NRTmakeSlot1 - $lisplibOperationAlist:= operationAlist - $lisplibMissingFunctions:= $CheckVectorList - lisplibWrite('"compilerInfo", - ['SETQ,'$CategoryFrame, - ['put,['QUOTE,op'],' - (QUOTE isFunctor), - ['QUOTE,operationAlist],['addModemap,['QUOTE,op'],[' - QUOTE,parForm],['QUOTE,parSignature],true,['QUOTE,op'], - ['put,['QUOTE,op' ],'(QUOTE mode), - ['QUOTE,['Mapping,:parSignature]],'$CategoryFrame]]]], $libFile) - if null argl then - evalAndRwriteLispForm('NILADIC, - ['MAKEPROP, ['QUOTE,op'], ['QUOTE,'NILADIC], true]) - [fun,['Mapping,:signature'],originale] - -makeFunctorArgumentParameters(argl,sigl,target) == - $alternateViewList: local:= nil - $forceAdd: local:= true - $ConditionalOperators: local - target := markKillAll target - ("append"/[fn(a,augmentSig(s,findExtras(a,target))) - for a in argl for s in sigl]) where - findExtras(a,target) == - -- see if conditional information implies anything else - -- in the signature of a - target is ['Join,:l] => "union"/[findExtras(a,x) for x in l] - target is ['CATEGORY,.,:l] => "union"/[findExtras1(a,x) for x in l] where - findExtras1(a,x) == - x is ['AND,:l] => "union"/[findExtras1(a,y) for y in l] - x is ['OR,:l] => "union"/[findExtras1(a,y) for y in l] - x is ['IF,c,p,q] => - union(findExtrasP(a,c), - union(findExtras1(a,p),findExtras1(a,q))) where - findExtrasP(a,x) == - x is ['AND,:l] => "union"/[findExtrasP(a,y) for y in l] - x is ['OR,:l] => "union"/[findExtrasP(a,y) for y in l] - x is ['has,=a,y] and y is ['SIGNATURE,:.] => [y] - nil - nil - augmentSig(s,ss) == - -- if we find something extra, add it to the signature - null ss => s - for u in ss repeat - $ConditionalOperators:=[CDR u,:$ConditionalOperators] - s is ['Join,:sl] => - u:=ASSQ('CATEGORY,ss) => - SUBST([:u,:ss],u,s) - ['Join,:sl,['CATEGORY,'package,:ss]] - ['Join,s,['CATEGORY,'package,:ss]] - fn(a,s) == - isCategoryForm(s,$CategoryFrame) => - s is ["Join",:catlist] => genDomainViewList0(a,rest s) - [genDomainView(a,a,s,"getDomainView")] - [a] - -compDefineCapsuleFunction(df,m,oldE,$prefix,$formalArgList) == - ['DEF,form,originalSignature,specialCases,body] := df - signature := markKillAll originalSignature - $markFreeStack: local := nil --holds "free variables" - $localImportStack : local := nil --local import stack for function - $localDeclareStack: local := nil - $localLoopVariables: local := nil - originalDef := COPY df - [lineNumber,:specialCases] := specialCases - e := oldE - --1. bind global variables - $form: local - $op: local - $functionStats: local:= [0,0] - $argumentConditionList: local - $finalEnv: local - --used by ReplaceExitEtc to get a common environment - $initCapsuleErrorCount: local:= #$semanticErrorStack - $insideCapsuleFunctionIfTrue: local:= true - $CapsuleModemapFrame: local:= e - $CapsuleDomainsInScope: local:= get("$DomainsInScope","special",e) - $insideExpressionIfTrue: local:= true - $returnMode:= m - [$op,:argl]:= form - $form:= [$op,:argl] - argl:= stripOffArgumentConditions argl - $formalArgList:= [:argl,:$formalArgList] - - --let target and local signatures help determine modes of arguments - argModeList:= - identSig:= hasSigInTargetCategory(argl,form,first signature,e) => - (e:= checkAndDeclare(argl,form,identSig,e); rest identSig) - [getArgumentModeOrMoan(a,form,e) for a in argl] - argModeList:= stripOffSubdomainConditions(argModeList,argl) - signature':= [first signature,:argModeList] - if null identSig then --make $op a local function - oldE := put($op,'mode,['Mapping,:signature'],oldE) - - --obtain target type if not given - if null first signature' then signature':= - identSig => identSig - getSignature($op,rest signature',e) or return nil - e:= giveFormalParametersValues(argl,e) - - $signatureOfForm:= signature' --this global is bound in compCapsuleItems - $functionLocations := [[[$op,$signatureOfForm],:lineNumber], - :$functionLocations] - e:= addDomain(first signature',e) - e:= compArgumentConditions e - - if $profileCompiler then - for x in argl for t in rest signature' repeat profileRecord('arguments,x,t) - - - --4. introduce needed domains into extendedEnv - for domain in signature' repeat e:= addDomain(domain,e) - - --6. compile body in environment with extended environment - rettype:= resolve(signature'.target,$returnMode) - - localOrExported := - null member($op,$formalArgList) and - getmode($op,e) is ['Mapping,:.] => 'local - 'exported - - --6a skip if compiling only certain items but not this one - -- could be moved closer to the top - formattedSig := formatUnabbreviated ['Mapping,:signature'] - $compileOnlyCertainItems and _ - not member($op, $compileOnlyCertainItems) => - sayBrightly ['" skipping ", localOrExported,:bright $op] - [nil,['Mapping,:signature'],oldE] - sayBrightly ['" compiling ",localOrExported, - :bright $op,'": ",:formattedSig] ----------------------> new <--------------------------------- - returnType := signature'.target --- trialT := returnType = "$" and get("Rep",'value,e) and comp(body,'Rep,e) - trialT := returnType = "$" and comp(body,$EmptyMode,e) - ------------------------------------------------------ 11/1/94 - -- try comp-ing in $EmptyMode; if succeed - -- if we succeed then trialT.mode = "$" or "Rep" - -- do a coerce to get the correct result - T := (trialT and coerce(trialT,returnType)) - -------------------------------------- 11/1/94 - or CATCH('compCapsuleBody, compOrCroak(body,returnType,e)) - markChanges(originalDef,T,$signatureOfForm) - [nil,['Mapping,:signature'],oldE] - --------------------------------- - -compCapsuleInner(itemList,m,e) == - e:= addInformation(m,e) - --puts a new 'special' property of $Information - data:= ["PROGN",:itemList] - --RPLACd by compCapsuleItems and Friends - e:= compCapsuleItems(itemList,nil,e) - BOUNDP '$convert2NewCompiler and $convert2NewCompiler => - [nil,m,e] --nonsense but that's fine - localParList:= $functorLocalParameters - if $addForm then data:= ['add,$addForm,data] - code:= - $insideCategoryIfTrue and not $insideCategoryPackageIfTrue => data - processFunctorOrPackage($form,$signature,data,localParList,m,e) - [MKPF([:$getDomainCode,code],"PROGN"),m,e] - -compSingleCapsuleItem(item,$predl,$e) == - $localImportStack : local := nil - $localDeclareStack: local := nil - $markFreeStack: local := nil - newItem := macroExpandInPlace(item,qe(25,$e)) - qe(26,$e) - doIt(newItem, $predl) - qe(27,$e) - $e - -compImport(["import",:doms],m,e) == - for dom in doms repeat - dom := markKillAll dom - markImport dom - e:=addDomain(dom,e) - ["/throwAway",$NoValueMode,e] - -mkUnion(a,b) == - b="$" and $Rep is ["Union",:l] => b - a is ["Union",:l] => - b is ["Union",:l'] => ["Union",:setUnion(l,l')] - member(b, l) => a - ["Union",:setUnion([b],l)] - b is ["Union",:l] => - member(a, l) => b - ["Union",:setUnion([a],l)] - STRINGP a => ["Union",b,a] - ["Union",a,b] - -compForMode(x,m,e) == - $compForModeIfTrue: local:= true - $convert2NewCompiler: local := nil - comp(x,m,e) - -compMakeCategoryObject(c,$e) == - not isCategoryForm(c,$e) => nil - c := markKillAll c - u:= mkEvalableCategoryForm c => [eval markKillAll u,$Category,$e] - nil - -macroExpand(x,e) == --not worked out yet - atom x => (u:= get(x,'macro,e) => macroExpand(u,e); x) - x is ['DEF,lhs,sig,spCases,rhs] => - ['DEF,macroExpand(lhs,e), macroExpandList(sig,e),macroExpandList(spCases,e), - macroExpand(rhs,e)] - x is ['MI,a,b] => - ['MI,a,macroExpand(b,e)] - macroExpandList(x,e) - -getSuccessEnvironment(a,e) == - -- the next four lines try to ensure that explicit special-case tests - -- prevent implicit ones from being generated - a is ["has",x,m] => - x := unLet x - IDENTP x and isDomainForm(m,$EmptyEnvironment) => put(x,"specialCase",m,e) - e - a is ["is",id,m] => - id := unLet id - IDENTP id and isDomainForm(m,$EmptyEnvironment) => - e:=put(id,"specialCase",m,e) - currentProplist:= getProplist(id,e) - [.,.,e] := T := comp(m,$EmptyMode,e) or return nil -- duplicates compIs - newProplist:= consProplistOf(id,currentProplist,"value",removeEnv T) - addBinding(id,newProplist,e) - e - a is ["case",x,m] and (x := unLet x) and IDENTP x => - put(x,"condition",[a,:get(x,"condition",e)],e) - e - -getInverseEnvironment(a,E) == - atom a => E - [op,:argl]:= a --- the next five lines try to ensure that explicit special-case tests --- prevent implicit ones from being generated - op="has" => - [x,m]:= argl - x := unLet x - IDENTP x and isDomainForm(m,$EmptyEnvironment) => put(x,"specialCase",m,E) - E - a is ["case",x,m] and (x := unLet x) and IDENTP x => - --the next two lines are necessary to get 3-branched Unions to work - -- old-style unions, that is - if corrupted? get(x,"condition",E) then systemError 'condition - (get(x,"condition",E) is [["OR",:oldpred]]) and member(a,oldpred) => - put(x,"condition",LIST MKPF(delete(a,oldpred),"OR"),E) - getUnionMode(x,E) is ["Union",:l] or systemError 'Union - if corrupted? l then systemError 'list - l':= delete(m,l) - for u in l' repeat - if u is ['_:,=m,:.] then l':= delete(u,l') - newpred:= MKPF([["case",x,m'] for m' in l'],"OR") - put(x,"condition",[newpred,:get(x,"condition",E)],E) - E - -unLet x == - x is ['LET,u,:.] => unLet u - x - -corrupted? u == - u is [op,:r] => - MEMQ(op,'(WI MI PART)) => true - or/[corrupted? x for x in r] - false - ---====================================================================== --- From apply.boot ---====================================================================== -applyMapping([op,:argl],m,e,ml) == - #argl^=#ml-1 => nil - isCategoryForm(first ml,e) => - --is op a functor? - pairlis:= [[v,:a] for a in argl for v in $FormalMapVariableList] - ml' := SUBLIS(pairlis, ml) - argl':= - [T.expr for x in argl for m' in rest ml'] where - T() == [.,.,e]:= comp(x,m',e) or return "failed" - if argl'="failed" then return nil - form:= [op,:argl'] ----------------------> new <---------------------------- - if constructor? op then form := markKillAll form ----------------------> new <---------------------------- - convert([form,first ml',e],m) - argl':= - [T.expr for x in argl for m' in rest ml] where - T() == [.,.,e]:= comp(x,m',e) or return "failed" - if argl'="failed" then return nil - form:= - not member(op,$formalArgList) and ATOM op and not get(op,'value,e) => - nprefix := $prefix or - -- following needed for referencing local funs at capsule level - getAbbreviation($op,#rest $form) - [op',:argl',"$"] where - op':= INTERN STRCONC(encodeItem nprefix,";",encodeItem op) - ['call,['applyFun,op],:argl'] - pairlis:= [[v,:a] for a in argl' for v in $FormalMapVariableList] - convert([form,SUBLIS(pairlis,first ml),e],m) - -compFormWithModemap(form,m,e,modemap) == - compFormWithModemap1(form,m,e,modemap,true) or compFormWithModemap1(form,m,e,modemap,false) - -compFormWithModemap1(form,m,e,modemap,Rep2Dollar?) == - [op,:argl] := form := markKillExpr form - [[dc,:.],:.] := modemap -----------> new: <----------- - if Rep2Dollar? then - if dc = 'Rep then - modemap := SUBST('Rep,'_$,modemap) - m := SUBST('Rep,'_$,m) - else return nil -----------> new: <----------- - [map:= [.,target,:.],[pred,impl]]:= modemap - -- this fails if the subsuming modemap is conditional - --impl is ['Subsumed,:.] => nil - if isCategoryForm(target,e) and isFunctor op then - [modemap,e]:= substituteIntoFunctorModemap(argl,modemap,e) or return nil - [map:= [.,target,:.],:cexpr]:= modemap - sv:=listOfSharpVars map - if sv then - -- SAY [ "compiling ", op, " in compFormWithModemap, - -- mode= ",map," sharp vars=",sv] - for x in argl for ss in $FormalMapVariableList repeat - if ss in sv then - [map:= [.,target,:.],:cexpr]:= modemap :=SUBST(x,ss,modemap) - -- SAY ["new map is",map] - not (target':= coerceable(target,m,e)) => nil - markMap := map - map:= [target',:rest map] - [f,Tl,sl]:= compApplyModemap(form,modemap,e,nil) or return nil - - --generate code; return - T:= - e':= - Tl => (LAST Tl).env - e - [x',m',e'] where - m':= SUBLIS(sl,map.(1)) - x':= - form':= [f,:[t.expr for t in Tl]] - m'=$Category or isCategoryForm(m',e) => form' - -- try to deal with new-style Unions where we know the conditions - op = "elt" and f is ['XLAM,:.] and IDENTP(z:=CAR argl) and - (c:=get(z,'condition,e)) and - c is [['case,=z,c1]] and - (c1 is ['_:,=(CADR argl),=m] or EQ(c1,CADR argl) ) => --- first is a full tag, as placed by getInverseEnvironment --- second is what getSuccessEnvironment will place there - ["CDR",z] - markTran(form,form',markMap,e') - qt(18,T) - convert(T,m) - -convert(T,m) == - tcheck T - qe(23,T.env) - coerce(T,resolve(T.mode,m) or return nil) - -compElt(origForm,m,E) == - form := markKillAll origForm - form isnt ["elt",aDomain,anOp] => compForm(origForm,m,E) - aDomain="Lisp" => - markLisp([anOp',m,E],E)where anOp'() == (anOp=$Zero => 0; anOp=$One => 1; anOp) - isDomainForm(aDomain,E) => - markImport opOf aDomain - E:= addDomain(aDomain,E) - mmList:= getModemapListFromDomain(anOp,0,aDomain,E) - modemap:= - n:=#mmList - 1=n => mmList.(0) - 0=n => - return - stackMessage ['"Operation ","%b",anOp,"%d", - '"missing from domain: ", aDomain] - stackWarning ['"more than 1 modemap for: ",anOp, - '" with dc=",aDomain,'" ===>" - ,mmList] - mmList.(0) -----------> new: <----------- - if aDomain = 'Rep then - modemap := SUBST('Rep,'_$,modemap) - m := SUBST('Rep,'_$,m) -----------> new: <----------- - [sig,[pred,val]]:= modemap - #sig^=2 and ^val is ["elt",:.] => nil --what does the second clause do ???? ---+ - val := genDeltaEntry [opOf anOp,:modemap] - x := markTran(origForm,[val],sig,[E]) - [x,first rest sig,E] --implies fn calls used to access constants - compForm(origForm,m,E) - -pause op == op -compApplyModemap(form,modemap,$e,sl) == - [op,:argl] := form --form to be compiled - [[mc,mr,:margl],:fnsel] := modemap --modemap we are testing - - -- $e is the current environment - -- sl substitution list, nil means bottom-up, otherwise top-down - - -- 0. fail immediately if #argl=#margl - - if #argl^=#margl then return nil - - -- 1. use modemap to evaluate arguments, returning failed if - -- not possible - - lt:= - [[.,m',$e]:= - comp(y,g,$e) or return "failed" where - g:= SUBLIS(sl,m) where - sl:= pmatchWithSl(m',m,sl) for y in argl for m in margl] - lt="failed" => return nil - - -- 2. coerce each argument to final domain, returning failed - -- if not possible - - lt':= [coerce(y,d) or return "failed" - for y in lt for d in SUBLIS(sl,margl)] - lt'="failed" => return nil - - -- 3. obtain domain-specific function, if possible, and return - - --$bindings is bound by compMapCond - [f,$bindings]:= compMapCond(op,mc,sl,fnsel) or return nil - ---+ can no longer trust what the modemap says for a reference into ---+ an exterior domain (it is calculating the displacement based on view ---+ information which is no longer valid; thus ignore this index and ---+ store the signature instead. - ---$NRTflag=true and f is [op1,d,.] and NE(d,'$) and member(op1,'(ELT CONST)) => - f is [op1,d,.] and member(op1,'(ELT CONST Subsumed)) => - [genDeltaEntry [op,:modemap],lt',$bindings] - markImport mc - [f,lt',$bindings] - -compMapCond''(cexpr,dc) == - cexpr=true => true - --cexpr = "true" => true ----------------> new <---------------------- - cexpr is [op,:l] and MEMQ(op,'(_and AND)) => and/[compMapCond''(u,dc) for u in l] - cexpr is [op,:l] and MEMQ(op,'(_or OR)) => or/[compMapCond''(u,dc) for u in l] ----------------> new <---------------------- - cexpr is ["not",u] => not compMapCond''(u,dc) - cexpr is ["has",name,cat] => (knownInfo cexpr => true; false) - --for the time being we'll stop here - shouldn't happen so far - --$disregardConditionIfTrue => true - --stackSemanticError(("not known that",'%b,name, - -- '%d,"has",'%b,cat,'%d),nil) - --now it must be an attribute - member(["ATTRIBUTE",dc,cexpr],get("$Information","special",$e)) => true - --for the time being we'll stop here - shouldn't happen so far - stackMessage ["not known that",'%b,dc,'%d,"has",'%b,cexpr,'%d] - false - ---====================================================================== --- From nruncomp.boot ---====================================================================== -NRTgetLocalIndex1(item,killBindingIfTrue) == - k := NRTassocIndex item => k - item = $NRTaddForm => 5 - item = '$ => 0 - item = '_$_$ => 2 - value:= - MEMQ(item,$formalArgList) => item - nil - atom item and null MEMQ(item,'($ _$_$)) - and null value => --give slots to atoms - $NRTdeltaList:= [['domain,NRTaddInner item,:value],:$NRTdeltaList] - $NRTdeltaListComp:=[item,:$NRTdeltaListComp] - $NRTdeltaLength := $NRTdeltaLength+1 - $NRTbase + $NRTdeltaLength - 1 - $NRTdeltaList:= [['domain,NRTaddInner item,:value],:$NRTdeltaList] - saveNRTdeltaListComp:= $NRTdeltaListComp:=[nil,:$NRTdeltaListComp] - saveIndex := $NRTbase + $NRTdeltaLength - $NRTdeltaLength := $NRTdeltaLength+1 - compEntry:= item - ----94/11/07 - -- WAS: compOrCroak(item,$EmptyMode,$e).expr - RPLACA(saveNRTdeltaListComp,compEntry) - saveIndex - -optDeltaEntry(op,sig,dc,eltOrConst) == - return nil --------> kill it - $killOptimizeIfTrue = true => nil - ndc := - dc = '$ => $functorForm - atom dc and (dcval := get(dc,'value,$e)) => dcval.expr - dc ---if (atom dc) and (dcval := get(dc,'value,$e)) --- then ndc := dcval.expr --- else ndc := dc - sig := SUBST(ndc,dc,sig) - not MEMQ(KAR ndc,$optimizableConstructorNames) => nil - dcval := optCallEval ndc - -- MSUBST guarantees to use EQUAL testing - sig := MSUBST(devaluate dcval, ndc, sig) - if rest ndc then - for new in rest devaluate dcval for old in rest ndc repeat - sig := MSUBST(new,old,sig) - -- optCallEval sends (List X) to (LIst (Integer)) etc, - -- so we should make the same transformation - fn := compiledLookup(op,sig,dcval) - if null fn then - -- following code is to handle selectors like first, rest - nsig := [quoteSelector tt for tt in sig] where - quoteSelector(x) == - not(IDENTP x) => x - get(x,'value,$e) => x - x='$ => x - MKQ x - fn := compiledLookup(op,nsig,dcval) - if null fn then return nil - eltOrConst="CONST" => - hehe fn - [op] -----------> return just the op here --- ['XLAM,'ignore,MKQ SPADCALL fn] - GETL(compileTimeBindingOf first fn,'SPADreplace) - -genDeltaEntry opMmPair == ---called from compApplyModemap ---$NRTdeltaLength=0.. always equals length of $NRTdeltaList - [.,[odc,:.],.] := opMmPair - --opModemapPair := SUBLIS($LocalDomainAlist,opMmPair) - [op,[dc,:sig],[.,cform:=[eltOrConst,:.]]] := opMmPair - if $profileCompiler = true then - profileRecord(dc,op,sig) --- markImport dc - eltOrConst = 'XLAM => cform - if eltOrConst = 'Subsumed then eltOrConst := 'ELT - -- following hack needed to invert Rep to $ substitution - if odc = 'Rep and cform is [.,.,osig] then sig:=osig - newimp := optDeltaEntry(op,sig,dc,eltOrConst) => newimp - setDifference(listOfBoundVars dc,$functorLocalParameters) ^= [] => - ['applyFun,['compiledLookupCheck,MKQ op, - mkList consSig(sig,dc),consDomainForm(dc,nil)]] - --if null atom dc then - -- sig := substitute('$,dc,sig) - -- cform := substitute('$,dc,cform) - opModemapPair := - [op,[dc,:[genDeltaSig x for x in sig]],['T,cform]] -- force pred to T - if null NRTassocIndex dc and dc ^= $NRTaddForm and - (member(dc,$functorLocalParameters) or null atom dc) then - --create "domain" entry to $NRTdeltaList - $NRTdeltaList:= [['domain,NRTaddInner dc,:dc],:$NRTdeltaList] - saveNRTdeltaListComp:= $NRTdeltaListComp:=[nil,:$NRTdeltaListComp] - $NRTdeltaLength := $NRTdeltaLength+1 - compEntry:= - dc - RPLACA(saveNRTdeltaListComp,compEntry) - chk(saveNRTdeltaListComp,102) - u := - [eltOrConst,'$,$NRTbase+$NRTdeltaLength-index] where index() == - (n:= POSN1(opModemapPair,$NRTdeltaList)) => n + 1 - --n + 1 since $NRTdeltaLength is 1 too large - $NRTdeltaList:= [opModemapPair,:$NRTdeltaList] - $NRTdeltaListComp:=[nil,:$NRTdeltaListComp] - $NRTdeltaLength := $NRTdeltaLength+1 - 0 - u - ---====================================================================== --- From nruncomp.boot ---====================================================================== -parseIf t == - t isnt [p,a,b] => t - ifTran(parseTran p,parseTran a,parseTran b) where - ifTran(p,a,b) == - null($InteractiveMode) and p='true => a - null($InteractiveMode) and p='false => b - p is ['not,p'] => ifTran(p',b,a) - p is ['IF,p',a',b'] => ifTran(p',ifTran(a',COPY a,COPY b),ifTran(b',a,b)) - p is ['SEQ,:l,['exit,1,p']] => - ['SEQ,:l,['exit,1,ifTran(p',incExitLevel a,incExitLevel b)]] - --this assumes that l has no exits - a is ['IF, =p,a',.] => ['IF,p,a',b] - b is ['IF, =p,.,b'] => ['IF,p,a,b'] --- makeSimplePredicateOrNil p is ['SEQ,:s,['exit,1,val]] => --- parseTran ['SEQ,:s,['exit,1,incExitLevel ['IF,val,a,b]]] - ['IF,p,a,b] - ---====================================================================== --- From parse.boot ---====================================================================== -parseNot u == ['not,parseTran first u] - -makeSimplePredicateOrNil p == nil - ---====================================================================== --- From g-cndata.boot ---====================================================================== -mkUserConstructorAbbreviation(c,a,type) == - if $AnalyzeOnly or $convert2NewCompiler then - $abbreviationStack := [[type,a,:c],:$abbreviationStack] - if not atom c then c:= CAR c -- Existing constructors will be wrapped - constructorAbbreviationErrorCheck(c,a,type,'abbreviationError) - clearClams() - clearConstructorCache(c) - installConstructor(c,type) - setAutoLoadProperty(c) - ---====================================================================== --- From iterator.boot ---====================================================================== - -compreduce(form is [.,op,x],m,e) == - T := compForm(form,m,e) or return nil - y := T.expr - RPLACA(y,"REDUCE") - ------------------<== distinquish this as the special reduce form - (y is ["REDUCE",:.]) and (id:= getIdentity(op,e)) and (u := comp0(id,m,e)) and - # getNumberTypesInScope() > 1 => markSimpleReduce([:y, ["@",u.expr,m]], T) - T - -compReduce1(form is ["REDUCE",op,.,collectForm],m,e,$formalArgList) == --------------------------------> 11/28 all new to preserve collect forms - markImport m - [collectOp,:itl,body]:= collectForm - $e:= e - itl:= [([.,$e]:= compIterator(x,$e) or return "failed").(0) for x in itl] - itl="failed" => return nil - e:= $e - T0 := comp0(body,m,e) or return nil - md := T0.mode - T1 := compOrCroak(collectForm,["List",md],e) - T := [["REDUCE",op,nil,T1.expr],md,T1.env] - markReduce(form,T) - -compIterator(it,e) == - it is ["IN",x,y] => - --these two lines must be in this order, to get "for f in list f" - --to give an error message if f is undefined - ---------------> new <--------------------- - [y',m,e] := markInValue(y, e) - x := markKillAll x - ------------------ - $formalArgList:= [x,:$formalArgList] - [.,mUnder]:= - modeIsAggregateOf("List",m,e) or modeIsAggregateOf("Vector",m,e) or return - stackMessage ["mode: ",m," must be a list or vector of some mode"] - if null get(x,"mode",e) then [.,.,e]:= - compMakeDeclaration([":",x,mUnder],$EmptyMode,e) or return nil - e:= put(x,"value",[genSomeVariable(),mUnder,e],e) - markReduceIn(it, [["IN",x,y'],e]) - it is ["ON",x,y] => ----------------> new <--------------------- - x := markKillAll x - ------------------ - $formalArgList:= [x,:$formalArgList] - y := markKillAll y - markImport m ----------------> new <--------------------- - [y',m,e]:= comp(y,$EmptyMode,e) or return nil - [.,mUnder]:= - modeIsAggregateOf("List",m,e) or return - stackMessage ["mode: ",m," must be a list of other modes"] - if null get(x,"mode",e) then [.,.,e]:= - compMakeDeclaration([":",x,m],$EmptyMode,e) or return nil - e:= put(x,"value",[genSomeVariable(),m,e],e) - [["ON",x,y'],e] - it is ["STEP",oindex,start,inc,:optFinal] => - index := markKillAll oindex - $formalArgList:= [index,:$formalArgList] - --if all start/inc/end compile as small integers, then loop - --is compiled as a small integer loop - final':= nil ----------------> new <--------------------- - u := smallIntegerStep(it,index,start,inc,optFinal,e) => u ----------------> new <--------------------- - [start,.,e]:= - comp(markKillAll start,$Integer,e) or return - stackMessage ["start value of index: ",start," must be an integer"] - [inc,.,e]:= - comp(markKillAll inc,$Integer,e) or return - stackMessage ["index increment:",inc," must be an integer"] - if optFinal is [final] then - [final,.,e]:= - comp(markKillAll final,$Integer,e) or return - stackMessage ["final value of index: ",final," must be an integer"] - optFinal:= [final] - indexmode:= - comp(CADDR it,$NonNegativeInteger,e) => $NonNegativeInteger - $Integer --- markImport ['Segment,indexmode] - if null get(index,"mode",e) then [.,.,e]:= - compMakeDeclaration([":",index,indexmode],$EmptyMode,e) or return nil - e:= put(index,"value",[genSomeVariable(),indexmode,e],e) - markReduceStep(it, [["STEP",markStep(index),start,inc,:optFinal],e]) - it is ["WHILE",p] => - [p',m,e]:= - comp(p,$Boolean,e) or return - stackMessage ["WHILE operand: ",p," is not Boolean valued"] - markReduceWhile(it, [["WHILE",p'],e]) - it is ["UNTIL",p] => markReduceUntil(it, ($until:= p; ['$until,e])) - it is ["|",x] => - u:= - comp(x,$Boolean,e) or return - stackMessage ["SUCHTHAT operand: ",x," is not Boolean value"] - markReduceSuchthat(it, [["|",u.expr],u.env]) - nil - -smallIntegerStep(it,index,start,inc,optFinal,e) == - start := markKillAll start - inc := markKillAll inc - optFinal := markKillAll optFinal - startNum := source2Number start - incNum := source2Number inc - mode := get(index,"mode",e) ---fail if -----> a) index has a mode that is not $SmallInteger -----> b) one of start,inc, final won't comp as a $SmallInteger - mode and mode ^= $SmallInteger => nil - null (start':= comp(start,$SmallInteger,e)) => nil - null (inc':= comp(inc,$SmallInteger,start'.env)) => nil - if optFinal is [final] and not (final':= comp(final,$SmallInteger,inc'.env)) then --- not (FIXP startNum and FIXP incNum) => return nil --- null FIXP startNum or ABSVAL startNum > 100 => return nil - -----> assume that optFinal is $SmallInteger - T := comp(final,$EmptyMode,inc'.env) or return nil - final' := T - maxSuperType(T.mode,e) ^= $Integer => return nil - givenRange := T.mode - indexmode:= $SmallInteger - [.,.,e]:= compMakeDeclaration([":",index,indexmode],$EmptyMode, - (final' => final'.env; inc'.env)) or return nil - range := - FIXP startNum and FIXP incNum => - startNum > 0 and incNum > 0 => $PositiveInteger - startNum < 0 and incNum < 0 => $NegativeInteger - incNum > 0 => $NonNegativeInteger --startNum = 0 - $NonPositiveInteger - givenRange => givenRange - nil - e:= put(index,"range",range,e) - e:= put(index,"value",[genSomeVariable(),indexmode,e],e) - noptFinal := - final' => - [final'.expr] - nil - [markStepSI(it,["ISTEP",index,start'.expr,inc'.expr,:noptFinal]),e] - -source2Number n == - n := markKillAll n - n = $Zero => 0 - n = $One => 1 - n - -compRepeatOrCollect(form,m,e) == - fn(form,[m,:$exitModeStack],[#$exitModeStack,:$leaveLevelStack],$formalArgList - ,e) where - fn(form,$exitModeStack,$leaveLevelStack,$formalArgList,e) == - $until: local - [repeatOrCollect,:itl,body]:= form - itl':= - [([x',e]:= compIterator(x,e) or return "failed"; x') for x in itl] - itl'="failed" => nil - targetMode:= first $exitModeStack --- pp '"---------" --- pp targetMode - bodyMode:= - repeatOrCollect="COLLECT" => - targetMode = '$EmptyMode => '$EmptyMode - (u:=modeIsAggregateOf('List,targetMode,e)) => - CADR u - (u:=modeIsAggregateOf('Vector,targetMode,e)) => - repeatOrCollect:='COLLECTV - CADR u - stackMessage('"Invalid collect bodytype") - return nil - -- If we're doing a collect, and the type isn't conformable - -- then we've boobed. JHD 26.July.1990 - $NoValueMode - [body',m',e']:= T := - -- (m1:= listOrVectorElementMode targetMode) and comp(body,m1,e) or - compOrCroak(body,bodyMode,e) or return nil - markRepeatBody(body, T) - if $until then - [untilCode,.,e']:= comp($until,$Boolean,e') - itl':= substitute(["UNTIL",untilCode],'$until,itl') - form':= [repeatOrCollect,:itl',body'] - m'':= - repeatOrCollect="COLLECT" => - (u:=modeIsAggregateOf('List,targetMode,e)) => CAR u - ["List",m'] - repeatOrCollect="COLLECTV" => - (u:=modeIsAggregateOf('Vector,targetMode,e)) => CAR u - ["Vector",m'] - m' ---------> new <-------------- - markImport m'' ---------> new <-------------- - markRepeat(form,coerceExit([form',m'',e'],targetMode)) - -chaseInferences(origPred,$e) == - pred := markKillAll origPred - ----------------------------12/4/94 do this immediately - foo hasToInfo pred where - foo pred == - knownInfo pred => nil - $e:= actOnInfo(pred,$e) - pred:= infoToHas pred - for u in get("$Information","special",$e) repeat - u is ["COND",:l] => - for [ante,:conseq] in l repeat - ante=pred => [foo w for w in conseq] - ante is ["and",:ante'] and member(pred,ante') => - ante':= delete(pred,ante') - v':= - LENGTH ante'=1 => first ante' - ["and",:ante'] - v':= ["COND",[v',:conseq]] - member(v',get("$Information","special",$e)) => nil - $e:= - put("$Information","special",[v',: - get("$Information","special",$e)],$e) - nil - $e - ---====================================================================== --- doit Code ---====================================================================== -doIt(item,$predl) == - $GENNO: local:= 0 - $coerceList: local := nil - ---> - if item is ['PART,.,a] then item := a - ------------------------------------- - item is ['SEQ,:.] => doItSeq item - isDomainForm(item,$e) => doItDomain item - item is ['LET,:.] => doItLet item - item is [":",a,t] => [.,.,$e]:= - markDeclaredImport markKillAll t - compOrCroak(item,$EmptyMode,$e) - item is ['import,:doms] => - item := ['import,:(doms := markKillAll doms)] - for dom in doms repeat - sayBrightly ['" importing ",:formatUnabbreviated dom] - [.,.,$e] := compOrCroak(item,$EmptyMode,$e) - wiReplaceNode(item,'(PROGN),10) - item is ["IF",:.] => doItIf(item,$predl,$e) - item is ["where",b,:l] => compOrCroak(item,$EmptyMode,$e) - item is ["MDEF",:.] => [.,.,$e]:= compOrCroak(item,$EmptyMode,$e) - item is ['DEF,:.] => doItDef item - T:= compOrCroak(item,$EmptyMode,$e) => doItExpression(item,T) - true => cannotDo() - -holdIt item == item - -doItIf(item is [.,p,x,y],$predl,$e) == - olde:= $e - [p',.,$e]:= qt(19,comp(p,$Boolean,$e)) or userError ['"not a Boolean:",p] - oldFLP:=$functorLocalParameters - if x^="noBranch" then ---> new <----------------------- - qe(20,compSingleCapsuleItem(x,[p,:$predl],getSuccessEnvironment(markKillAll p,$e))) ----> new ----------- - x':=localExtras(oldFLP) - where localExtras(oldFLP) == - EQ(oldFLP,$functorLocalParameters) => NIL - flp1:=$functorLocalParameters - oldFLP':=oldFLP - n:=0 - while oldFLP' repeat - oldFLP':=CDR oldFLP' - flp1:=CDR flp1 - n:=n+1 - -- Now we have to add code to compile all the elements - -- of functorLocalParameters that were added during the - -- conditional compilation - nils:=ans:=[] - for u in flp1 repeat -- is =u form always an ATOM? - if ATOM u or (or/[v is [.,=u,:.] for v in $getDomainCode]) - then - nils:=[u,:nils] - else - gv := GENSYM() - ans:=[['LET,gv,u],:ans] - nils:=[gv,:nils] - n:=n+1 - - $functorLocalParameters:=[:oldFLP,:REVERSE nils] - REVERSE ans - oldFLP:=$functorLocalParameters - if y^="noBranch" then ---> new <----------------------- - qe(21,compSingleCapsuleItem(y,[['not, p],:$predl],getInverseEnvironment(markKillAll p,olde))) ---> ----------- - y':=localExtras(oldFLP) - wiReplaceNode(item,["COND",[p',x,:x'],['(QUOTE T),y,:y']],12) - -doItSeq item == - ['SEQ,:l,['exit,1,x]] := item - RPLACA(item,"PROGN") - RPLACA(LASTNODE item,x) - for it1 in rest item repeat $e:= compSingleCapsuleItem(it1,$predl,$e) - -doItDomain item == - -- convert naked top level domains to import - u:= ['import, [first item,:rest item]] - markImport CADR u - stackWarning ["Use: import ", [first item,:rest item]] ---wiReplaceNode(item, u, 14) - RPLACA(item, first u) - RPLACD(item, rest u) - doIt(item,$predl) - -doItLet item == - qe(3,$e) - res := doItLet1 item - qe(4,$e) - res - -doItLet1 item == - ['LET,lhs,rhs,:.] := item - not (compOrCroak(item,$EmptyMode,$e) is [code,.,$e]) => - stackSemanticError(["cannot compile assigned value to",:bright lhs],nil) - qe(5,$e) - code := markKillAll code - not (code is ['LET,lhs',rhs',:.] and atom lhs') => - code is ["PROGN",:.] => - stackSemanticError(["multiple assignment ",item," not allowed"],nil) - wiReplaceNode(item, code, 24) - lhs:= lhs' - if not member(KAR rhs,$NonMentionableDomainNames) and - not MEMQ(lhs, $functorLocalParameters) then - $functorLocalParameters:= [:$functorLocalParameters,lhs] - if (rhs' := rhsOfLetIsDomainForm code) then - if isFunctor rhs' then - $functorsUsed:= insert(opOf rhs',$functorsUsed) - $packagesUsed:= insert([opOf rhs'],$packagesUsed) - $globalImportDefAlist := pp [[lhs, :rhs'],:$globalImportDefAlist] - if lhs="Rep" then - $Representation:= (get("Rep",'value,$e)).(0) - --$Representation bound by compDefineFunctor, used in compNoStacking ---+ - if $NRTopt = true - then NRTgetLocalIndex $Representation ---+ - $LocalDomainAlist:= --see genDeltaEntry - [[lhs,:SUBLIS($LocalDomainAlist,get(lhs,'value,$e).0)],:$LocalDomainAlist] ---+ - qe(6,$e) - code is ['LET,:.] => - rhsCode:= rhs' - op := ($QuickCode => 'QSETREFV;'SETELT) - wiReplaceNode(item,[op,'$,NRTgetLocalIndexClear lhs,rhsCode], 16) - wiReplaceNode(item, code, 18) - -rhsOfLetIsDomainForm code == - code is ['LET,.,rhs',:.] => - isDomainForm(rhs',$e) => rhs' - isDomainForm(rhs' := markKillAll rhs',$e) => rhs' - false - false - -doItDef item == - ['DEF,[op,:.],:.] := item - body:= isMacro(item,$e) => $e:= put(op,'macro,body,$e) - [.,.,$e]:= t:= compOrCroak(item,$EmptyMode,$e) - chk(item,3) - RPLACA(item,"CodeDefine") - --Note that DescendCode, in CodeDefine, is looking for this - RPLACD(CADR item,[$signatureOfForm]) - chk(item,4) - --This is how the signature is updated for buildFunctor to recognise ---+ - functionPart:= ['dispatchFunction,t.expr] - wiReplaceNode(CDDR item,[functionPart], 20) - chk(item, 30) - -doItExpression(item,T) == - SETQ($ITEM,COPY item) - SETQ($T1,COPY T.expr) - chk(T.expr, 304) - u := markCapsuleExpression(item, T) - [code,.,$e]:= u - wiReplaceNode(item,code, 22) - -wiReplaceNode(node,ocode,key) == - ncode := CONS(first ocode, rest ocode) - code := replaceNodeInStructureBy(node,ncode) - SETQ($NODE,COPY node) - SETQ($NODE1, COPY first code) - SETQ($NODE2, COPY rest code) - RPLACA(node,first code) - RPLACD(node,rest code) - chk(code, key) - chk(node, key + 1) - -replaceNodeInStructureBy(node, x) == - $nodeCopy: local := [CAR node,:CDR node] - replaceNodeBy(node, x) - node - -replaceNodeBy(node, x) == - atom x => nil - for y in tails x | EQCAR(x,node) repeat RPLAC(CAR x, $nodeCopy) - nil - -chk(x,key) == fn(x,0,key) where fn(x,cnt,key) == - cnt > 10000 => - sayBrightly ["--> ", key, " <---"] - hahaha(key) - atom x => cnt - VECP x => systemError nil - for y in x repeat cnt := fn(y, cnt + 1, key) - cnt - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/xrun.boot b/src/interp/xrun.boot index b6be04c5..925d1c16 100644 --- a/src/interp/xrun.boot +++ b/src/interp/xrun.boot @@ -1,5 +1,7 @@ -- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are diff --git a/src/interp/xruncomp.boot b/src/interp/xruncomp.boot index 4b558a3e..ffd4b211 100644 --- a/src/interp/xruncomp.boot +++ b/src/interp/xruncomp.boot @@ -1,5 +1,7 @@ -- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are -- cgit v1.2.3