diff options
Diffstat (limited to 'src/interp')
| -rw-r--r-- | src/interp/Makefile.in | 27 | ||||
| -rw-r--r-- | src/interp/as.boot | 1190 | ||||
| -rw-r--r-- | src/interp/ax.boot | 385 | ||||
| -rw-r--r-- | src/interp/axext_l.lisp | 208 | ||||
| -rw-r--r-- | src/interp/daase.lisp | 344 | ||||
| -rw-r--r-- | src/interp/foam_l.lisp | 842 | ||||
| -rw-r--r-- | src/interp/i-syscmd.boot | 245 | ||||
| -rw-r--r-- | src/interp/sys-driver.boot | 1 | ||||
| -rw-r--r-- | src/interp/util.lisp | 91 |
9 files changed, 17 insertions, 3316 deletions
diff --git a/src/interp/Makefile.in b/src/interp/Makefile.in index aca72a48..ec291d40 100644 --- a/src/interp/Makefile.in +++ b/src/interp/Makefile.in @@ -75,7 +75,7 @@ OBJS= boot-pkg.$(FASLEXT) types.$(FASLEXT) \ cattable.$(FASLEXT) posit.$(FASLEXT) \ cformat.$(FASLEXT) clam.$(FASLEXT) \ clammed.$(FASLEXT) nlib.$(FASLEXT) \ - comp.$(FASLEXT) foam_l.$(FASLEXT) \ + comp.$(FASLEXT) \ pathname.$(FASLEXT) compat.$(FASLEXT) \ serror.$(FASLEXT) ptrees.$(FASLEXT) \ cparse.$(FASLEXT) cstream.$(FASLEXT) \ @@ -110,7 +110,7 @@ OBJS= boot-pkg.$(FASLEXT) types.$(FASLEXT) \ termrw.$(FASLEXT) \ trace.$(FASLEXT) daase.$(FASLEXT) \ fortcall.$(FASLEXT) i-parser.$(FASLEXT) \ - $(OCOBJS) $(BROBJS) $(ASCOMP) $(INOBJS) + $(OCOBJS) $(BROBJS) $(INOBJS) # Last minite patches. # FIXMEL: should be folded into the main object list. @@ -141,11 +141,6 @@ BROBJS= bc-matrix.$(FASLEXT) \ autoload_objects += $(BFOBJS) -ASCOMP= as.$(FASLEXT) axext_l.$(FASLEXT) - -ASAUTO= ${AUTO}/ax.$(FASLEXT) - -autoload_objects += $(ASAUTO) TIMESTAMP=$(axiom_targetdir)/timestamp YEARWEEK=(progn (defconstant timestamp "${TIMESTAMP}") \ (setq *build-version* "$(PACKAGE_STRING)") \ @@ -209,15 +204,15 @@ makeint.lisp: Makefile @ echo '(in-package "BOOT")' >> makeint.lisp @ touch ${TIMESTAMP} @ echo '${YEARWEEK}' >> makeint.lisp - @ echo '(unless (or |$$StandardLinking| (|%basicSystemIsComplete|)) (build-interpsys (quote ($(patsubst %, "%", ${ASAUTO}))))(|clearClams|))' >> makeint.lisp - @ echo '#+:akcl (setq compiler::*suppress-compiler-notes* t)' >> makeint.lisp - @ echo '#+:akcl (si::gbc-time 0)' >> makeint.lisp + @ echo '(unless (or |$$StandardLinking| (|%basicSystemIsComplete|)) (build-interpsys)(|clearClams|))' >> makeint.lisp + @ echo '#+:gcl (setq compiler::*suppress-compiler-notes* t)' >> makeint.lisp + @ echo '#+:gcl (si::gbc-time 0)' >> makeint.lisp @ echo '#+:GCL (si::gbc t)' >> makeint.lisp ${SAVESYS}: database.date \ $(axiom_targetdir)/algebra/exposed.$(FASLEXT) \ $(axiom_target_datadir)/msgs/s2-us.msgs \ - $(ASAUTO) $(OBJS) makeint.$(LNKEXT) + $(OBJS) makeint.$(LNKEXT) $(DRIVER) --execpath=$(BOOTSYS) \ --syslib=$(axiom_target_libdir) \ --system="$(AXIOM)/" --system-algebra \ @@ -234,7 +229,7 @@ all-axiomsys: ${AXIOMSYS} ${AXIOMSYS}: database.date \ $(axiom_targetdir)/algebra/exposed.$(FASLEXT) \ $(axiom_target_datadir)/msgs/s2-us.msgs \ - $(ASAUTO) $(OBJS) makeint.$(LNKEXT) + $(OBJS) makeint.$(LNKEXT) $(DRIVER) --execpath=$(BOOTSYS) \ --syslib=$(axiom_target_libdir) \ --system="$(AXIOM)/" \ @@ -340,10 +335,6 @@ newfort.$(FASLEXT): macros.$(FASLEXT) lisplib.$(FASLEXT): nlib.$(FASLEXT) c-util.$(FASLEXT) debug.$(FASLEXT) interop.$(FASLEXT): interop.boot c-util.$(FASLEXT) hashcode.$(FASLEXT) c-doc.$(FASLEXT): c-util.$(FASLEXT) - -## Interface with the Aldor compiler. -ax.$(FASLEXT): as.$(FASLEXT) -as.$(FASLEXT): macros.$(FASLEXT) server.$(FASLEXT): macros.$(FASLEXT) ## @@ -400,7 +391,7 @@ bits.$(FASLEXT): boot-pkg.$(FASLEXT) dq.$(FASLEXT): types.$(FASLEXT) ## General support and utilities. -daase.$(FASLEXT): macros.$(FASLEXT) foam_l.$(FASLEXT) +daase.$(FASLEXT): macros.$(FASLEXT) spaderror.$(FASLEXT): macros.$(FASLEXT) debug.$(FASLEXT): macros.$(FASLEXT) parsing.$(FASLEXT) spad.$(FASLEXT): bootlex.$(FASLEXT) postpar.$(FASLEXT) debug.$(FASLEXT) @@ -437,8 +428,6 @@ sys-constants.$(FASLEXT): types.$(FASLEXT) hash.$(FASLEXT): types.$(FASLEXT) union.$(FASLEXT): vmlisp.$(FASLEXT) ggreater.$(FASLEXT): vmlisp.$(FASLEXT) -axext_l.$(FASLEXT): foam_l.$(FASLEXT) -foam_l.$(FASLEXT): vmlisp.$(FASLEXT) sys-constants.$(FASLEXT) lisp-backend.$(FASLEXT): sys-macros.$(FASLEXT) sys-utility.$(FASLEXT): vmlisp.$(FASLEXT) sys-os.$(FASLEXT) hash.$(FASLEXT) vmlisp.$(FASLEXT): types.$(FASLEXT) sys-globals.$(FASLEXT) diff --git a/src/interp/as.boot b/src/interp/as.boot deleted file mode 100644 index c7533f8b..00000000 --- a/src/interp/as.boot +++ /dev/null @@ -1,1190 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- Copyright (C) 2007-2011, 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 -namespace BOOT - ---global hash tables for new compiler -$docHash := MAKE_-HASH_-TABLE() -$conHash := MAKE_-HASH_-TABLE() -$opHash := MAKE_-HASH_-TABLE() -$asyPrint := false - -asList() == - removeFile '"temp.text" - OBEY '"ls as/*.asy > temp.text" - instream := inputTextFile '"temp.text" - lines := [line := readLine instream while line ~= %nothing] - closeStream 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 | tableValue($conHash,x) isnt [.,.,"function",:.]] - $mmAlist : local := - [[con,:asyConstructorModemap con] for con in conlist] - $docAlist : local := - [[con,:removeDuplicates asyDocumentation con] for con in conlist] - $parentsHash : local := MAKE_-HASH_-TABLE() ---$childrenHash: local := MAKE_-HASH_-TABLE() - for con in conlist repeat - parents := asyParents con - tableValue($parentsHash,con) := asyParents con --- for [parent,:pred] in parents repeat --- parentOp := opOf parent --- tableValue($childrenHash,parentOp) := insert([con,:pred],tableValue($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 modemap.mmTarget - for x in folks $constructorCategory repeat --- x := applySubst(pairList(formals,formalParams),x) --- x := applySubst(pairList(formalParams,IFCDR conform),x) --- x := substitute('Type,'Object,x) - acc := [:explodeIfs x,:acc] - reverse! 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 := makeSymbol PATHNAME_-NAME asyFile --- modemap := --- [[[name],['CATEGORY,'domain, --- :[asyMkSignature(con,mm.mmSignature) for [con,:mm] in $mmAlist]]],['T,name]] --- opAlist := [[con,[mm.mmSignature]] for [con,:mm] in $mmAlist] --- documentation := --- [[con,[mm.mmSignature,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 := tableValue($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 is 'function => asMakeAlistForFunction con - abb := asyAbbreviation(con,#(KDR sig)) - if null KDR form then - property(opOf form,'NILADIC) := 'T - modemap := asySubstMapping LASSOC(con,$mmAlist) - $constructorCategory :local := modemap.mmTarget - parents := mySort tableValue($parentsHash,con) ---children:= mySort tableValue($childrenHash,con) - alists := tableValue($opHash,con) - opAlist := applySubst(pairList(KDR form,$FormalMapVariableList),CDDR alists) - ancestorAlist := - applySubst(pairList(KDR form,$FormalMapVariableList),first alists) - catAttrs := [[x,:true] for x in getAttributesFromCATEGORY $constructorCategory] - attributeAlist := removeDuplicates [:second alists,:catAttrs] - documentation := - applySubst(pairList(KDR form,$FormalMapVariableList),LASSOC(con,$docAlist)) - filestring := strconc(PATHNAME_-NAME STRINGIMAGE filename,'".as") - constantPart := tableValue($constantHash,con) and [['constant,:true]] - niladicPart := symbolMember?(con,$niladics) and [['NILADIC,:true]] - falist := TAKE(#KDR form,$FormalMapVariableList) - constructorCategory := - kind is 'category => - talist := TAKE(#KDR form, $TriangleVariableList) - applySubst(pairList(falist,talist),$constructorCategory) - applySubst(pairList(KDR form,falist),$constructorCategory) - if constructorCategory='Category then kind := 'category - exportAlist := asGetExports(kind, form, constructorCategory) - constructorModemap := applySubst(pairList(KDR form,falist),modemap) ---TTT fix a niladic category constructormodemap (remove the joins) - if kind is 'category then - constructorModemap.mmTarget := $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 := tableValue($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 - '(("form" . getConstructorFormFromDB) _ - ("kind" . getConstructorKindFromDB) _ - ("modemap" . getConstructorModemapFromDB) _ - ("abbreviation" . getConstructorAbbreviationFromDB) _ - ("category" . getConstructorCategoryFromDB) _ - ("parents" . getConstructorParentsFromDB) _ - ("attributes" . getConstructorAttributesFromDB) _ - ("ancestors" . getConstructorAncestorsFromDB) _ - ("source file" . getConstructorSourceFileFromDB) _ - ("all operations" . getConstructorOperationsFromDB) _ - ("operation modemap" . getOperationModemapsFromDB) _ - ("documentation" . getConstructorDocumentationFromDB)) repeat fn(x,y) - where - fn(x,y) == - sayBrightly ['"----------------- ",first y,'" --------------------"] - pp FUNCALL(rest y, x) - --- 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 --- digit? stringChar(PNAME op,0) => u.first := 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:= - kind in '(category function) => rest $PatternVariableList -- *1 is special for $ - $PatternVariableList - form := [opOf oform,:[y for x in KDR oform for y in rpvl]] - dc := - kind in '(category function) => "*1" - form - pred1 := - kind is 'category => [["*1",form]] - nil - signature := modemap.mmSignature - domainList := - [[a,m] for a in rest form for m in rest signature | - asIsCategoryForm m] - catPredList:= - kind is 'function => [["isFreeFunction","*1",opOf form]] - [['ofCategory,:u] for u in [:pred1,:domainList]] --- for [op,:itemlist] in applySubst(pairList($FormalMapVariableList,rpvl),opAlist) repeat --- the code seems to oscillate between generating $FormalMapVariableList --- and generating $TriangleVariableList - for [op,:itemlist] in applySubst(pairList($FormalMapVariableList,rpvl),opAlist) repeat - for [sig0, pred] in itemlist repeat - sig := substitute(dc,"$",sig0) - pred:= substitute(dc,"$",pred) - sig := applySubst(pairList(KDR oform,rpvl),sig) - pred:= applySubst(pairList(KDR oform,rpvl),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] - reverse! acc - -asIsCategoryForm m == - m = "BasicType" or getConstructorKindFromDB opOf m = "category" - -asyDocumentation con == - docHash := tableValue($docHash,con) - u := [[op,:[fn(x,op) for x in rec]] for op in HKEYS docHash - | rec := tableValue(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 tableValue($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) - k := STRPOS('"Author:",str,0,nil) => asyExtractDescription subString(str,0,k) - str - -trimComments str == - str = nil or str is '"" => '"" - m := maxIndex str - str := subString(str,0,m) - trimString str - -asyExportAlist con == ---format of 'operationAlist property of LISPLIBS (as returned from koOps): --- <sig slotNumberOrNil optPred optELT> --- <sig sig' predOrT "Subsumed"> ---!!! asyFile NEED: need to know if function is implemented by domain!!! - docHash := tableValue($docHash,con) - [[op,:[fn(x,op) for x in rec]] for op in HKEYS docHash | rec := tableValue(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 := symbolLassoc('domExports,proplist) => - kind := 'domain - u - u := symbolLassoc('catExports,proplist) => - kind := 'category - u - key is '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 := - symbolLassoc('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] - tableValue(ht,id) := [entry,:tableValue(ht,id)] - opalist := [[op,:removeDuplicates tableValue(ht,op)] for op in HKEYS ht] - --tableValue($opHash,con) := [ancestorAlist,attributeAlist,:opalist] - tableValue($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 op in '(PretendTo RestrictTo) => asyAncestors y - atom x => - x is '_% => '_$ - symbolMember?(x, $niladics) => [x] - niladicConstructorFromDB x => [x] - x - asyAncestorList x - -asyAncestorList x == [asyAncestors y for y in x] ---============================================================================ --- Build Operation Alist from sig ---============================================================================ - ---format of operations as returned from koOps --- <sig pred pakOriginOrNil TifPakExposedOrNil> --- <sig pred origin exposed?> - ---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: --- <sig pred origin exposed? comments> - inStream := inputTextFile 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() - tableValue($docHash,name) := $docHashLocal - closeStream 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 is 'failed => id - KAR dform isnt 'Declare => systemError '"asytranDeclaration" - if levels is '(top) then - if form isnt ['Apply,"->",:.] then tableValue($constantHash,id) := true - comments := symbolLassoc('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,:.] => - id in '(%% Category Type) => 'constant - asyLooksLikeCatForm? form => 'category - form is ['Apply, '_-_>,.,u] => - if u is ['Apply, construc,:.] then u:= construc - getConstructorKindFromDB opOf u = "domain" => "function" - asyLooksLikeCatForm? u => "category" - 'domain - 'domain - first levels - typeCode := symbolLassoc('symeTypeCode,r) - record := [idForm,newsig,asyMkpred predlist,key,true,comments,typeCode,:$asyFile] - if not local? then - ht := - levels is '(top) => $conHash - $docHashLocal - tableValue(ht,id) := [record,:tableValue(ht,id)] - if levels is '(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 is '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 tableValue($constantHash,id) := true --- comments := symbolLassoc('documentation,r) or '"" --- newsig := asytranForm(form,[idForm,:levels],local?) --- key := --- id in '(%% Category Type) => 'constant --- form is ['Apply,'Third,:.] => 'category --- form is ['Apply,.,.,target] and target is ['Apply,name,:.] --- and name in '(Third Join) => 'category --- 'domain --- record := [newsig,asyMkpred predlist,key,true,comments,:$asyFile] --- if not local? then --- ht := --- levels is '(top) => $conHash --- $docHashLocal --- tableValue(ht,id) := [record,:tableValue(ht,id)] --- if levels is '(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 a in '(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 is 'Category => asytranForm1(rest,levels, local?) - asytranForm1(x,levels,local?) - error '"DEFINE forms are not handled yet" - if form is '_% then $hasPerCent := true - IDENTP form => - form is "%" => "$" - form has NILADIC => [form] - form - [asytranForm(x,levels,local?) for x in form] - -asytranApply(['Apply,name,:arglist],levels,local?) == - name in '(Record Union) => - [name,:[asytranApplySpecial(x, levels, local?) for x in arglist]] - null arglist => [name] - name is [ 'RestrictTo, :.] => - asytranApply(['Apply, second name,:arglist], levels, local?) - name is [ 'Qualify, :.] => - asytranApply(['Apply, second name,:arglist], levels, local?) - name is 'string => asytranLiteral first arglist - name is 'integer => asytranLiteral first arglist - name is 'float => asytranLiteral first arglist - name is '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) == - second 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] => - tableValue(catTable,id) := [asyWrap(record,predlist),:tableValue(catTable,id)] - catList := [asyWrap(dform,predlist),:catList] - keys := listSort(function GLESSEQP,HKEYS catTable) - right1 := reverse! catList - right2 := [[key,:tableValue(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?) - KAR x in '(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 := tableValue($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 is 'With => 'T - nil - t is '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 => makeSymbol stringUpcase name - parts := asySplit(name,maxIndex name) - newname := strconc/[asyShorten x for x in parts] - #newname < 8 => makeSymbol newname - tryname := subString(name,0,7) - not createAbbreviation tryname => makeSymbol stringUpcase tryname - nil - chk(conname,abb) == - (xx := asyGetAbbrevFromComments conname) => xx - con := abbreviation? abb => - conname = con => abb - conname - abb - -asyGetAbbrevFromComments con == - docHash := tableValue($docHash,con) - u := [[op,:[fn(x,op) for x in rec]] for op in HKEYS docHash - | rec := tableValue(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 tableValue($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) - 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 lowerCase? name.i repeat k := i - k := k + 1 - [subString(name,0,k),:asySplit(subString(name,k),end-k)] - -createAbbreviation s == - if string? s then s := makeSymbol s - a := getConstructorAbbreviationFromDB s - a ~= s => a - nil - ---============================================================================ --- extending getConstructorModemapFromDB Property ---============================================================================ ---Note: modemap property is built when getConstructorModemapFromDB is called - -asyConstructorModemap con == - tableValue($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]] - applySubst(pairList(['_%,:$constructorArgs],formals),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 is 'Join => asyTypeJoin r ---------> jump out to newer code 4/94 - fn in '(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 is 'With => asyCATEGORY r - fn is 'Third => - r is [b] => - b is ['With,:s] => asyCATEGORY s - b is ['Blank,:.] => asyCATEGORY nil - error x - fn is 'Apply and r is ['_-_>,:s] => asyMapping(s,name?) - fn is '_-_> => asyMapping(r,name?) - fn is 'Declare and r is [name,typ,:.] => - asySig1(typ, name?, target?) - x is '(_%) => '(_$) - [fn,:[asySig(x,name?) for x in r]] ---x is 'Type => $Type - x is '_% => '_$ - 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 is 'Join => asyTypeJoin r - fn in '(RestrictTo PretendTo) => asyType first r - asyComma? fn => - u := [asyType x for x in r] - u - fn is 'With => asyCATEGORY r - fn is '_-_> => asyTypeMapping r - fn is 'Apply => r --- fn is 'Declare and r is [name,typ,:.] => typ - x is '(_%) => '(_$) - x ---x is 'Type => $Type - x is '_% => '_$ - 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] - rest 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 stringChar(symbolName 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 is 'Join => systemError 'Join ----->asyTypeJoin r - fn in '(RestrictTo PretendTo) => asyTypeUnit first r - asyComma? fn => - u := [asyTypeUnit x for x in r] - u - fn is 'With => asyCATEGORY r - fn is '_-_> => asyTypeMapping r - fn is 'Apply => asyTypeUnitList r - fn is 'Declare and r is [name,typ,:.] => asyTypeUnitDeclare(name,typ) - x is '(_%) => '(_$) - [fn,:asyTypeUnitList r] - GETL(x,"NILADIC") => [x] ---x is 'Type => $Type - x is '_% => '_$ - 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 cons? x repeat x := first x - if symbolMember?(x, $BuiltinAttributes) 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 op in '(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 is '_% => '_$ - 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 == op in '(Comma Multi) - - -hput(table,name,value) == - if null name then systemError() - tableValue(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 is 'category then - tvl := TAKE(#rest conform,$TriangleVariableList) - res := applySubst(pairList(tvl,$FormalMapVariableList),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 is '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/ax.boot b/src/interp/ax.boot deleted file mode 100644 index e3728a78..00000000 --- a/src/interp/ax.boot +++ /dev/null @@ -1,385 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd. --- All rights reserved. --- Copyright (C) 2007-2011, 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 -namespace 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 == - [makeSymbol(con,"BOOT") for con in SRCABBREVS SOURCEPATH STRING name] - -makeAxFile(filename, constructors) == - $defaultFlag : local := false - $literals := [] - axForms := - [modemapToAx(modemap) for cname in constructors | - (modemap:=getConstructorModemapFromDB cname) 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) - closeStream st - -makeAxExportForm(filename, constructors) == - $defaultFlag : local := false - $literals := [] - axForms := - [modemapToAx(modemap) for cname in constructors | - (modemap:=getConstructorModemapFromDB cname) 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 := getConstructorCategoryFromDB constructor - categoryInfo := applySubst(pairList($TriangleVariableList,$FormalMapVariableList), - 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)]]] - symbolMember?(constructor,$extendedDomains) => - null args => - ['Extend, ['Define, ['Declare, constructor, resultType], - ['Add, ['PretendTo, ['Add, [], []], resultType], []]]] - conscat := makeSymbol(strconc(symbolName(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 getDualSignatureFromDB constructor --- 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 getDualSignatureFromDB constructor --- 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 is '$ then sym := '% - opOf type in '(StreamAggregate FiniteLinearAggregate) => - ['Declare, sym, 'Type] - ['Declare, sym, axFormatType type] - -makeTypeSequence l == - ['Sequence,: removeSymbol(l,'Type)] - -axFormatAttrib(typeform) == - atom typeform => typeform - axFormatType typeform - -axFormatType(typeform) == - atom typeform => - typeform is '$ => '% - string? typeform => - ['Apply,'Enumeration, makeSymbol typeform] - integer? typeform => - -- need to test for PositiveInteger vs Integer - axAddLiteral('integer, 'PositiveInteger, 'Literal) - ['RestrictTo, ['LitInteger, STRINGIMAGE typeform ], 'PositiveInteger] - FLOATP typeform => ['LitFloat, STRINGIMAGE typeform] - symbolMember?(typeform,$TriangleVariableList) => - applySubst(pairList($TriangleVariableList, $FormalMapVariableList), typeform) - symbolMember?(typeform, $FormalMapVariableList) => typeform - axAddLiteral('string, 'Symbol, 'Literal) - ['RestrictTo, ['LitString, symbolName 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 is '$ => '% - op is '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 := - string? x => makeSymbol x - x is ['QUOTE,val] and string? val => makeSymbol 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 second typeform, 'SetCategory]] - typeform is ['FileCategory,xx,['Record,:args]] => - ['Apply, 'FileCategory, axFormatType xx, - ['PretendTo, axFormatType third typeform, 'SetCategory]] - typeform is [op,:args] => - $pretendFlag and constructor? op and - getConstructorModemapFromDB op is [[.,target,:argtypes],.] => - ['Apply, op, - :[['PretendTo, axFormatType a, axFormatType t] - for a in args for t in argtypes]] - op in '(SquareMatrix SquareMatrixCategory DirectProduct - DirectProductCategory RadixExpansion) and - getConstructorModemapFromDB op 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 is 'elt => 'apply - name is 'setelt => 'set! - name is 'SEGMENT => ".." - name is 1 => '_1 - name is 0 => '_0 - name - opOf name is 'Zero => '_0 - opOf name is '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 is 'IF => axFormatOp pred - op = "has" => - [name,type] := args - if name is '$ 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 is 'AND => ['And,:axArglist] - op is 'OR => ['Or,:axArglist] - op is '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 := getConstructorOperationsFromDB catname - [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) is '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. - applySubst(pairList(rest $FormalMapVariableList,$FormalMapVariableList), - dcSig(numvec,index,numOfArgs)) - index := index + numOfArgs + 1 - slotNumber := numvec.index - if not listMember?([op,signumList],$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/axext_l.lisp b/src/interp/axext_l.lisp deleted file mode 100644 index ad3d5088..00000000 --- a/src/interp/axext_l.lisp +++ /dev/null @@ -1,208 +0,0 @@ -;; Copyright (C) 1991-2002, The Numerical Algorithms Group Ltd. -;; All rights reserved. -;; Copyright (C) 2007-2008, 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. - - -;; File containing primitives needed by exextend in order to interop with axiom -;; This file could do with some declares - -(import-module "foam_l") -(in-package "FOAM-USER") - -;; Literals should be null-terminated strings - -;; SingleInteger - -(eval-when (:compile-toplevel :load-toplevel :execute) - (progn - -(defmacro |AXL-LiteralToSingleInteger| (l) - `(parse-integer ,l :junk-allowed t)) - -(defmacro |AXL-LiteralToInteger| (l) - `(parse-integer ,l :junk-allowed t)) - -(defmacro |AXL-LiteralToDoubleFloat| (l) - `(read-from-string ,l nil (|DFlo0|) - :preserve-whitespace t)) - -(defmacro |AXL-LiteralToString| (l) - `(subseq ,l 0 (- (length ,l) 1))) - -(defmacro |AXL-SingleIntegerToInteger| (si) - `(coerce (the |SInt| ,si) |BInt|)) - -(defmacro |AXL-StringToFloat| (s) - `(boot::|string2Float| ,s)) - -(defmacro |AXL-IntegerIsNonNegative| (i) - `(not (< ,i 0))) - -(defmacro |AXL-IntegerIsPositive| (i) - `(< 0 (the |BInt| ,i))) - -(defmacro |AXL-plusInteger| (a b) - `(the |BInt| (+ (the |BInt| ,a) - (the |BInt| ,b)))) - -(defmacro |AXL-minusInteger| (a b) - `(the |BInt| (- (the |BInt| ,a) - (the |BInt| ,b)))) - -(defmacro |AXL-timesInteger| (a b) - `(the |BInt| (* (the |BInt| ,a) - (the |BInt| ,b)))) - -(defmacro |AXL-eqInteger| (a b) - `(= (the |BInt| ,a) - (the |BInt| ,b))) - -(defmacro |AXL-ltInteger| (a b) - `(< (the |BInt| ,a) - (the |BInt| ,b))) - -(defmacro |AXL-leInteger| (a b) - `(<= (the |BInt| ,a) - (the |BInt| ,b))) - -(defmacro |AXL-gtInteger| (a b) - `(> (the |BInt| ,a) - (the |BInt| ,b))) - -(defmacro |AXL-geInteger| (a b) - `(>= (the |BInt| ,a) - (the |BInt| ,b))) - -(defmacro |AXL-plusSingleInteger| (a b) - `(the |SInt| (+ (the |SInt| ,a) - (the |SInt| ,b)))) - -(defmacro |AXL-minusSingleInteger| (a b) - `(the |SInt| (- (the |SInt| ,a) - (the |SInt| ,b)))) - -(defmacro |AXL-timesSingleInteger| (a b) - `(the |SInt| (* (the |SInt| ,a) - (the |SInt| ,b)))) - -(defmacro |AXL-eqSingleInteger| (a b) - `(= (the |SInt| ,a) - (the |SInt| ,b))) - -(defmacro |AXL-ltSingleInteger| (a b) - `(< (the |SInt| ,a) - (the |SInt| ,b))) - -(defmacro |AXL-leSingleInteger| (a b) - `(<= (the |SInt| ,a) - (the |SInt| ,b))) - -(defmacro |AXL-gtSingleInteger| (a b) - `(> (the |SInt| ,a) - (the |SInt| ,b))) - -(defmacro |AXL-geSingleInteger| (a b) - `(>= (the |SInt| ,a) - (the |SInt| ,b))) - -(defmacro |AXL-incSingleInteger| (i) - `(the |SInt| (+ (the |SInt| ,i) 1))) - -(defmacro |AXL-decSingleInteger| (i) - `(- (the |SInt| ,i) - (the |SInt| 1))) - -(defmacro |AXL-onefnSingleInteger| () '(the |SInt| 1)) -(defmacro |AXL-zerofnSingleInteger| () '(the |SInt| 0)) - -(defmacro |AXL-cons| (x y) - `(cons ,x ,y)) - -(defmacro |AXL-nilfn| () nil) - -(defmacro |AXL-car| (x) `(car ,x)) - -(defmacro |AXL-cdr| (x) `(cdr ,x)) - -(defmacro |AXL-null?| (x) `(null ,x)) - -(defmacro |AXL-rplaca| (x y) `(rplaca ,x ,y)) - -(defmacro |AXL-rplacd| (x y) `(rplacd ,x ,y)) - -(defmacro |AXL-error| (msg) `(error ,msg)) - -;; arrays -;; 0 based! -(defmacro |AXL-arrayRef| (arr i) - `(|AElt| ,arr ,i)) - -(defmacro |AXL-arraySet| (arr i v) - `(setf (|AElt| ,arr ,i) ,v)) - -(defmacro |AXL-arrayToList| (x) - `(coerce ,x 'list)) - -(defmacro |AXL-arraySize| (x) - `(length ,x)) - -(defmacro |AXL-arrayNew| (n) - `(make-array ,n)) - -(defmacro |AXL-arrayCopy| (x) - `(copy-seq ,x)) - -;; Vectors - -;; tacky but means we can run programs - -(defun H-integer (l e) - (|AXL-LiteralToInteger| l)) - -(defun H-string (l e) - (|AXL-LiteralToString| l)) - -(defun H-error (l e) - (|AXL-error| l)) - -)) - -(eval-when (load eval) - (defconstant |G-axclique_string_305639517| (cons #'H-String nil)) - (defconstant |G-axclique_integer_685864888| (cons #'H-integer nil)) - (defconstant |G-axclique_error_011667951| (cons #'H-error nil))) - -;; Testing - -(defun |AXL-spitSInt| (x) - (print x)) - diff --git a/src/interp/daase.lisp b/src/interp/daase.lisp index 1a86d669..ad849541 100644 --- a/src/interp/daase.lisp +++ b/src/interp/daase.lisp @@ -1,6 +1,6 @@ ;; Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd. ;; All rights reserved. -;; Copyright (C) 2007-2010, Gabriel Dos Reis. +;; Copyright (C) 2007-2011, Gabriel Dos Reis. ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without @@ -110,7 +110,7 @@ ; This file contains the code to build, open and access the .DAASE -; files this file contains the code to )library NRLIBS and asy files +; files this file contains the code to )library NRLIBS ; There is a major issue about the data that resides in these ; databases. the fundamental problem is that the system requires more @@ -202,7 +202,6 @@ (import-module "macros") (in-package "AxiomCore") -(import-module "foam_l") (in-package "BOOT") (defstruct database @@ -324,18 +323,8 @@ (defvar *allOperations* nil "a list of all the operations in the system") -(defvar *asharpflags* - "-O -laxiom -Fasy -Flsp" "library compiler flags") - (defvar |$ConstructorCache| nil) -(defun asharp (file &optional (flags *asharpflags*)) - "call the asharp compiler" - (|runProgram| - (concatenate 'string (|systemRootDirectory|) "/compiler/bin/axiomxl") - (list flags file))) - - (defun |closeAllDatabaseStreams| nil (close *interp-stream*) (close *operation-stream*) @@ -826,10 +815,6 @@ (setq stream *interp-stream*) (when (setq struct (get constructor 'database)) (setq data (database-object struct)))) - (asharp? - (setq stream *interp-stream*) - (when (setq struct (get constructor 'database)) - (setq data (database-object struct)))) (niladic (setq stream *interp-stream*) (when (setq struct (get constructor 'database)) @@ -946,10 +931,6 @@ (concatenate 'string (|systemRootDirectory|) "src/algebra/" data)))) - (asharp? ; is this asharp code? - (if (consp data) - (setq data (cdr data)) - (setq data nil))) (object ; fix up system object pathname (if (consp data) (setq data @@ -973,8 +954,6 @@ ; localdatabase tries to find files in the order of: ; NRLIB/index.KAF -; .asy -; .ao, then asharp to .asy (defun localdatabase (filelist options &optional (make-database? nil)) "read a local filename and update the hash tables" @@ -1000,13 +979,11 @@ (aldorFiles (|getAllAldorObjectFiles| dirarg))) (values indexFiles - (first aldorFiles) - (second aldorFiles) ;; At the moment we will only look for user.lib: others - ;; are taken care of by localasy and localnrlib. + ;; are taken care of by localnrlib. nil )))) - (let (thisdir nrlibs asos asys libs object only dir key + (let (thisdir nrlibs libs object only dir key (|$forceDatabaseUpdate| t) noexpose) (declare (special |$forceDatabaseUpdate|)) (setq thisdir (get-current-directory)) @@ -1016,7 +993,7 @@ (if make-database? (setq noexpose t)) (if dir - (multiple-value-setq (nrlibs asys asos libs) + (multiple-value-setq (nrlibs libs) (processDir (|ensureTrailingSlash| (string dir))))) (dolist (file filelist) (let ((filename (pathname-name file)) @@ -1031,18 +1008,6 @@ ".NRLIB/" |$IndexFilename|))) (push (namestring file) nrlibs)) - ((setq file (probe-file - (concatenate 'string - namedir - filename - ".asy"))) - (push (namestring file) asys)) - ((setq file (probe-file - (concatenate 'string - namedir - filename - ".ao"))) - (push (namestring file) asos)) ('else (format t " )library cannot find the file ~a.~%" filename))))) (dolist (file (|reverse!| nrlibs)) (setq key (pathname-name (first (last (pathname-directory file))))) @@ -1050,108 +1015,9 @@ (directory-namestring file) "code." |$faslType|)) (localnrlib key file object make-database? noexpose)) - (dolist (file (|reverse!| asys)) - (setq object - (concatenate 'string - (directory-namestring file) - (pathname-name file))) - (localasy (|astran| file) object only make-database? noexpose)) - (dolist (file (|reverse!| asos)) - (setq object - (concatenate 'string - (directory-namestring file) - (pathname-name file))) - (asharp file) - (setq file (|astran| (concatenate 'string - (pathname-name file) - ".asy"))) - (localasy file object only make-database? noexpose)) (HCLEAR |$ConstructorCache|)))) -(defun localasy (asy object only make-database? noexpose) - "given an alist from the asyfile and the objectfile update the database" - (labels ( - (fetchdata (alist index) - (cdr (assoc index alist :test #'string=)))) - (let (cname kind key alist (systemdir? nil) - oldmaps asharp-name dbstruct abbrev) - (set-file-getter object) ; sets the autoload property for G-object - (dolist (domain asy) - (setq key (first domain)) - (setq alist (rest domain)) - (setq asharp-name - (foam::axiomxl-global-name (pathname-name object) key - (lassoc '|typeCode| alist))) - (if (< (length alist) 4) ;we have a naked function object - (let ((opname key) - (modemap (car (LASSOC '|modemaps| alist))) ) - (setq oldmaps (|getOperationFromDB| opname)) - (setf (gethash opname *operation-hash*) - (adjoin (subst asharp-name opname (cdr modemap)) - oldmaps :test #'equal)) - (asharpMkAutoloadFunction object asharp-name)) - (when (if (null only) (not (eq key '%%)) (member key only)) - (setq *allOperations* nil) ; force this to recompute - (setq oldmaps (|getOperationModemapsFromDB| key)) - (setq dbstruct (make-database)) - (setf (get key 'database) dbstruct) - (setq *allconstructors* (adjoin key *allconstructors*)) - (setf (database-constructorform dbstruct) - (fetchdata alist "constructorForm")) - (setf (database-constructorkind dbstruct) - (fetchdata alist "constructorKind")) - (setf (database-constructormodemap dbstruct) - (fetchdata alist "constructorModemap")) - (unless (setf (database-abbreviation dbstruct) - (fetchdata alist "abbreviation")) - (setf (database-abbreviation dbstruct) key)) ; default - (setq abbrev (database-abbreviation dbstruct)) - (setf (get abbrev 'abbreviationfor) key) - (setf (database-constructorcategory dbstruct) - (fetchdata alist "constructorCategory")) - (setf (database-attributes dbstruct) - (fetchdata alist "attributes")) - (setf (database-sourcefile dbstruct) - (fetchdata alist "sourceFile")) - (setf (database-operationalist dbstruct) - (fetchdata alist "operationAlist")) - (setf (database-modemaps dbstruct) - (fetchdata alist "modemaps")) - (setf (database-documentation dbstruct) - (fetchdata alist "documentation")) - (setf (database-predicates dbstruct) - (fetchdata alist "predicates")) - (setf (database-niladic dbstruct) - (fetchdata alist "NILADIC")) - (addoperations key oldmaps) - (setq cname (|opOf| (database-constructorform dbstruct))) - (setq kind (database-constructorkind dbstruct)) - (if (null noexpose) (|setExposeAddConstr| (cons cname nil))) - (unless make-database? - (|updateDatabase| key cname systemdir?) ;makes many hashtables??? - (|installConstructor| cname kind) - ;; following can break category database build - (if (eq kind '|category|) - (setf (database-ancestors dbstruct) - (fetchdata alist "ancestors"))) - (if (eq kind '|domain|) - (dolist (pair (cdr (assoc "ancestors" alist :test #'string=))) - (setf (gethash (cons cname (caar pair)) *hascategory-hash*) - (cdr pair)))) - (if |$InteractiveMode| - (setq |$CategoryFrame| |$EmptyEnvironment|))) - (setf (database-cosig dbstruct) - (cons nil (mapcar #'|categoryForm?| - (cddar (database-constructormodemap dbstruct))))) - (setf (database-object dbstruct) (cons object asharp-name)) - (if (eq kind '|category|) - (asharpMkAutoLoadCategory object cname asharp-name - (database-cosig dbstruct)) - (asharpMkAutoLoadFunctor object cname asharp-name - (database-cosig dbstruct))) - (|sayKeyedMsg| 'S2IU0001 (list cname object)))))))) - (defun localnrlib (key nrlib object make-database? noexpose) "given a string pathname of an index.KAF and the object update the database" (labels @@ -1339,7 +1205,6 @@ ; does gethash calls into it rather than doing a getdatabase call. (write-interpdb) #+:AKCL (write-warmdata) - (create-initializers) (when (probe-file (final-name "compress")) (delete-file (final-name "compress"))) (rename-file "compress.build" (final-name "compress")) @@ -1609,202 +1474,3 @@ (maphash #'(lambda (k v) (declare (ignore v)) (push k *allOperations*)) *operation-hash*)) *allOperations*) - -; the variable NOPfuncall is a funcall-able object that is a dummy -; initializer for libaxiom asharp domains. -(defvar NOPfuncall (cons 'identity nil)) - -(defun create-initializers () -;; since libaxiom is now built with -name=axiom following unnecessary -;; (dolist (con (|allConstructors|)) -;; (let ((sourcefile (|getConstructorSourceFileFromDB| con))) -;; (if sourcefile -;; (set (foam::axiomxl-file-init-name (pathname-name sourcefile)) -;; NOPfuncall)))) - (setf (symbol-value (foam::axiomxl-file-init-name "axiom")) NOPfuncall) -;; (set (foam::axiomxl-file-init-name "axclique") NOPfuncall) - (setf (symbol-value (foam::axiomxl-file-init-name "filecliq")) NOPfuncall) - (setf (symbol-value (foam::axiomxl-file-init-name "attrib")) NOPfuncall) -;; following needs to happen inside restart since $AXIOM may change - (let ((asharprootlib (strconc (|systemRootDirectory|) "/aldor/lib/"))) - (set-file-getter (strconc asharprootlib "runtime")) - (set-file-getter (strconc asharprootlib "lang")) - (set-file-getter (strconc asharprootlib "attrib")) - (set-file-getter (strconc asharprootlib "axlit")) - (set-file-getter (strconc asharprootlib "minimach")) - (set-file-getter (strconc asharprootlib "axextend")))) - - - -;--------------------------------------------------------------------- - -; how the magic works: -; when a )library is done on a new compiler file we set up multiple -; functions (refered to as autoloaders). there is an autoloader -; stored in the symbol-function of the G-filename (e.g. G-basic) -; (see set-file-getter function) -; and an autoloader stored in the symbol-function of every domain -; in the basic.as file ( asharpMkAutoloadFunctor ) -; When a domain is needed the autoloader for the domain is executed. -; this autoloader invokes file-getter-name to get the name of the -; file (eg basic) and evaluates the name. the FIRST time this is done -; for a file the file will be loaded by its autoloader, then it will -; return the file object. every other time the file is already -; loaded and the file object is returned directly. -; Once the file object is gotten getconstructor is called to get the -; domain. the FIRST time this is done for the domain the autoloader -; invokes the file object. every other time the domain already -; exists. -;(defvar *this-file* "no-file") - -(defmacro |CCall| (fun &rest args) - (let ((ccc (gensym)) (cfun (gensym)) (cenv (gensym))) - `(let ((,ccc ,fun)) - (let ((,cfun (|ClosFun| ,ccc)) - (,cenv (|ClosEnv| ,ccc))) - (funcall ,cfun ,@args ,cenv ))))) - -(defmacro |ClosFun| (x) `(car ,x)) -(defmacro |ClosEnv| (x) `(cdr ,x)) - -(defun file-runner (name) - (declare (special foam-user::|G-domainPrepare!|)) - (|CCall| foam-user::|G-domainPrepare!| (|CCall| name))) - -(defun getConstructor (file-fn asharp-name) - (|CCall| file-fn) -; (eval (cdr (assoc file-id (get name 'asharp-name) :test #'equal)))) - (eval asharp-name)) - -(defun getop (dom op type) - (declare (special foam-user::|G-domainGetExport!|)) - (|CCall| foam-user::|G-domainGetExport!| dom - (|hashString| (symbol-name op)) type)) - -; the asharp compiler will allow both constant domains and domains -; which are functions. localasy sets the autoload property so that -; the symbol-function contains a function that, when invoked with -; the correct number of args will return a domain. - -; this function is called if we are given a new compiler domain -; which is a function. the symbol-function of the domain is set -; to call the function with the correct number of arguments. - -(defun wrapDomArgs (obj type?) - (cond ((not type?) obj) - (t (|makeOldAxiomDispatchDomain| obj)))) - -(defun asharpMkAutoLoadFunctor (file cname asharp-name cosig) - (setf (symbol-function cname) - #'(lambda (&rest args) - (let ((func (getconstructor (eval (file-getter-name file)) asharp-name))) - (setf (symbol-function cname) - (if (vectorp (car func)) - #'(lambda () func) ;; constant domain - #'(lambda (&rest args) - (apply (|ClosFun| func) - (|append!| - (mapcar #'wrapDomArgs args (cdr cosig)) - (list (|ClosEnv| func))))))) - (apply cname args))))) - -(defun asharpMkAutoLoadCategory (file cname asharp-name cosig) - (asharpMkAutoLoadFunctor file cname asharp-name cosig) - (let ((packname (INTERN (STRCONC cname '"&")))) - (setf (symbol-function packname) - #'(lambda (self &rest args) - (let ((func (getconstructor (eval (file-getter-name file)) asharp-name))) - (setf (symbol-function packname) - (if (vectorp (car func)) - #'(lambda (self) - (|CCall| (elt (car func) 5) (cdr func) (wrapDomArgs self t))) ;; constant category - #'(lambda (self &rest args) - (let ((precat - (apply (|ClosFun| func) - (|append!| - (mapcar #'wrapDomArgs args (cdr cosig)) - (list (|ClosEnv| func)))))) - (|CCall| (elt (car precat) 5) (cdr precat) (wrapDomArgs self t)))))) - (apply packname self args)))))) - -(defun asharpMkAutoLoadFunction (file asharpname) - (setf (symbol-value asharpname) - (cons - #'(lambda (&rest l) - (let ((args (butlast l)) - (func (getconstructor (eval (file-getter-name file)) asharpname))) - (apply (car func) (append args (list (cdr func)))))) - ()))) - -; this function will return the internal name of the file object getter - -(defun file-getter-name (filename) - (foam::axiomxl-file-init-name (pathname-name filename))) - -;;need to initialize |G-filename| to a function which loads file -;; and then returns the new value of |G-filename| - -(defun set-file-getter (filename) - (let ((getter-name (file-getter-name filename))) - (setf (symbol-value getter-name) - (cons #'init-file-getter (cons getter-name filename))))) - -(defun init-file-getter (env) - (let ((getter-name (car env)) - (filename (cdr env))) - (load filename) - (|CCall| (eval getter-name)))) - -(defun set-lib-file-getter (filename cname) - (let ((getter-name (file-getter-name filename))) - (setf (symbol-value getter-name) - (cons #'init-lib-file-getter (cons getter-name cname))))) - -(defun init-lib-file-getter (env) - (let* ((getter-name (car env)) - (cname (cdr env)) - (filename (|getConstructorModuleFromDB| cname))) - (load filename) - (|CCall| (eval getter-name)))) - -;; following 2 functions are called by file-exports and file-imports macros -(defun foam::process-import-entry (entry) - (let* ((asharpname (car entry)) - (stringname (cadr entry)) - (hcode (caddr entry)) - (libname (cadddr entry)) - (bootname (intern stringname 'boot))) - (declare (ignore libname)) - (if (and (eq hcode 'foam-user::|initializer|) (not (boundp asharpname))) - (error (format nil "AxiomXL file ~s is missing!" stringname))) - (unless (or (not (numberp hcode)) (zerop hcode) (boundp asharpname)) - (when (|constructor?| bootname) - (setf (symbol-value asharpname) - (if (|niladicConstructorFromDB| bootname) - (|makeLazyOldAxiomDispatchDomain| (list bootname)) - (cons '|runOldAxiomFunctor| bootname)))) - (when (|attribute?| bootname) - (setf (symbol-value asharpname) - (|makeLazyOldAxiomDispatchDomain| bootname)))))) - - - -;(defun foam::process-export-entry (entry) -; (let* ((asharpname (car entry)) -; (stringname (cadr entry)) -; (hcode (caddr entry)) -; (libname (cadddr entry)) -; (bootname (intern stringname 'boot))) -; (declare (ignore libname)) -; (when (numberp hcode) -; (setf (get bootname 'asharp-name) -; (cons (cons *this-file* asharpname) -; (get bootname 'asharp-name))) -; ))) - - - - - - - diff --git a/src/interp/foam_l.lisp b/src/interp/foam_l.lisp deleted file mode 100644 index d2ca464c..00000000 --- a/src/interp/foam_l.lisp +++ /dev/null @@ -1,842 +0,0 @@ -;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -;; All rights reserved. -;; Copyright (C) 2007-2011, 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. - - -;; -;; FOAM is the intermediate language for the aldor compiler. FOAM -;; means "first order abstract machine" and functions similar to -;; RTL for the GCC compiler. It is a "machine" that is used as the -;; target for meta-assembler level statments. These are eventually -;; expanded for the real target machine (or interpreted directly) -;; - -;;; -;;; FOAM Operations for Common Lisp -;;; - -;; -;; Client files should begin with -;; (in-package "FOAM-USER" :use '("FOAM" "LISP")) -;; -;; -;; To Do: -;; Test cases. -;; Scan and format functions need to be rewritten to handle complete syntax. -;; Deftypes for each Foam type? -;; - -#+:common-lisp (in-package "COMMON-LISP-USER") -#-:common-lisp (in-package "USER") - -(defpackage "FOAM" - #+:common-lisp (:use "COMMON-LISP") - #-:common-lisp (:use "LISP")) - - -;; FOAM-USER is the package containing foam statements and macros -;; that get inserted into user code versus the foam package which -;; provides support for compiler code. - -(defpackage "FOAM-USER" - #+:common-lisp (:use "COMMON-LISP") - #-:common-lisp (:use "LISP") - (:use "FOAM")) - -#+:gcl (in-package "BOOT") -(in-package "AxiomCore") -(import-module "vmlisp") -(import-module "sys-constants") - -(in-package "FOAM") - -(export '( - compile-as-file cases - - |Clos| |Char| |Bool| |Byte| |HInt| |SInt| |BInt| |DFlo| |Ptr| - |Word| |Arb| |Env| |Level| |Arr| |Record| |Nil| - - |ClosInit| |CharInit| |BoolInit| |ByteInit| |HIntInit| |SIntInit| - |BIntInit| |DFloInit| |PtrInit| |WordInit| |ArbInit| |EnvInit| - |ArrInit| |RecordInit| |LevelInit| - - |BoolFalse| |BoolTrue| |BoolNot| |BoolAnd| |BoolOr| |BoolEQ| |BoolNE| - - |CharSpace| |CharNewline| |CharMin| |CharMax| |CharIsDigit| - |CharIsLetter| |CharEQ| |CharNE| |CharLT| |CharLE| - |CharLower| |CharUpper| |CharOrd| |CharNum| |CharCode0| - - |DFlo0| |DFlo1| |DFloMin| |DFloMax| |DFloEpsilon| - |DFloIsZero| |DFloIsNeg| |DFloIsPos| |DFloEQ| |DFloNE| - |DFloLT| |DFloLE| |DFloNegate| |DFloPrev| |DFloNext| - |DFloPlus| |DFloMinus| |DFloTimes| |DFloTimesPlus| - |DFloDivide| |DFloRPlus| |DFloRMinus| |DFloRTimes| - |DFloRTimesPlus| |DFloRDivide| |DFloDissemble| - |DFloAssemble| |Byte0| |Byte1| |ByteMin| |ByteMax| - - |HInt0| |HInt1| |HIntMin| |HIntMax| - - |SInt0| |SInt1| |SIntMin| |SIntMax| |SIntIsZero| |SIntIsNeg| - |SIntIsPos| |SIntIsEven| |SIntIsOdd| |SIntEQ| |SIntNE| - |SIntLT| |SIntLE| |SIntNegate| |SIntPrev| |SIntNext| - |SIntPlus| |SIntMinus| |SIntTimes| |SIntTimesPlus| - |SIntMod| |SIntQuo| |SIntRem| |SIntDivide| |SIntGcd| - |SIntPlusMod| |SIntMinusMod| |SIntTimesMod| - |SIntTimesModInv| |SIntLength| |SIntShiftUp| - |SIntShiftDn| |SIntBit| |SIntNot| |SIntAnd| |SIntOr| - - |WordTimesDouble| |WordDivideDouble| |WordPlusStep| |WordTimesStep| - - |BInt0| |BInt1| |BIntIsZero| |BIntIsNeg| |BIntIsPos| |BIntIsEven| - |BIntIsOdd| |BIntIsSingle| |BIntEQ| |BIntNE| |BIntLT| - |BIntLE| |BIntNegate| |BIntPrev| |BIntNext| |BIntPlus| - |BIntMinus| |BIntTimes| |BIntTimesPlus| |BIntMod| - |BIntQuo| |BIntRem| |BIntDivide| |BIntGcd| - |BIntSIPower| |BIntBIPower| |BIntLength| |BIntShiftUp| - |BIntShiftDn| |BIntBit| - - |PtrNil| |PtrIsNil| |PtrMagicEQ| |PtrEQ| |PtrNE| - - |FormatDFlo| |FormatSInt| |FormatBInt| - |fgetss| |fputss| - - |ScanDFlo| |ScanSInt| |ScanBInt| - - |ByteToSInt| |SIntToByte| |HIntToSInt| - |SIntToHInt| |SIntToBInt| |BIntToSInt| - |SIntToDFlo| |BIntToDFlo| |PtrToSInt| - |SIntToPtr| |BoolToSInt| - - |ArrToDFlo| |ArrToSInt| |ArrToBInt| - - |PlatformRTE| |PlatformOS| |Halt| - - |Clos| |CCall| |ClosEnv| |ClosFun| |SetClosEnv| |SetClosFun| - |DDecl| |RNew| |ANew| |RElt| |EElt| |AElt| |Lex| - |SetLex| |SetRElt| |SetAElt| |SetEElt| - |FoamFree| - - declare-prog declare-type - defprog ignore-var block-return - defspecials file-exports file-imports - typed-let foamfn |FoamProg| |alloc-prog-info| - - |MakeEnv| |EnvLevel| |EnvNext| |EnvInfo| |SetEnvInfo| |FoamEnvEnsure| - |MakeLit| |MakeLevel| - |printNewLine| |printChar| |printString| |printSInt| |printBInt| - |printDFloat| - |strLength| |formatSInt| |formatBInt| |formatDFloat| - - |ProgHashCode| |SetProgHashCode| |ProgFun| - |G-mainArgc| |G-mainArgv| - |stdinFile| |stdoutFile| |stderrFile| - |fputc| |fputs| |foamfun| - - - ;; trancendental functions - |sqrt| |pow| |log| |exp| |sin| |cos| |tan| |sinh| |cosh| |tanh| - |asin| |acos| |atan| |atan2| - - ;; debuging - |fiSetDebugVar| |fiGetDebugVar| |fiSetDebugger| |fiGetDebugger| - ;; Blatent hacks.. - |G-stdoutVar| |G-stdinVar| |G-stderrVar| - |fiStrHash| - - axiomxl-file-init-name - axiomxl-global-name -)) - - -;; type defs for Foam types -(deftype |Char| () 'BOOT::|%Char|) -(deftype |Clos| () 'list) -(deftype |Bool| () '(member t nil)) -(deftype |Byte| () 'BOOT::|%Byte|) -(deftype |HInt| () '(integer #.(- (expt 2 15)) #.(1- (expt 2 15)))) -(deftype |SInt| () 'BOOT::|%Short|) - -(deftype |BInt| () 'BOOT::|%Integer|) - -(deftype |DFlo| () 'BOOT::|%DoubleFloat|) - -(deftype |Level| () t) ;; structure?? - -(deftype |Nil| () t) -(deftype |Ptr| () t) -(deftype |Word| () t) -(deftype |Arr| () t) -(deftype |Record| () t) -(deftype |Arb| () t) -(deftype |Env| () t) ; (or cons nil) - -;; default values for types. Used as initializers in lets. -(defconstant |CharInit| (the |Char| '#\Space)) -(defconstant |ClosInit| (the |Clos| nil)) -(defconstant |BoolInit| (the |Bool| nil)) -(defconstant |ByteInit| (the |Byte| 0)) -(defconstant |HIntInit| (the |HInt| 0)) -(defconstant |SIntInit| (the |SInt| 0)) -(defconstant |BIntInit| (the |BInt| 0)) -(defconstant |DFloInit| (coerce 0 '|DFlo|)) -(defconstant |PtrInit| (the |Ptr| nil)) -(defconstant |ArrInit| (the |Arr| nil)) -(defconstant |RecordInit| (the |Record| nil)) -(defconstant |WordInit| (the |Word| nil)) -(defconstant |ArbInit| (the |Arb| nil)) -(defconstant |EnvInit| (the |Env| nil)) -(defconstant |LevelInit| (the |Level| nil)) - -;; Bool values are assumed to be either 'T or NIL. -;; Thus non-nil values are canonically represented. -(defmacro |BoolFalse| () NIL) -(defmacro |BoolTrue| () 'T) -(defmacro |BoolNot| (x) `(NOT ,x)) -(defmacro |BoolAnd| (x y) - `(let ((xx ,x) (yy ,y)) (AND xx yy))) ;; force evaluation of both args -(defmacro |BoolOr| (x y) - `(let ((xx ,x) (yy ,y)) (OR xx yy))) ;; force evaluation of both args -(defmacro |BoolEQ| (x y) `(EQ ,x ,y)) -(defmacro |BoolNE| (x y) `(NOT (|BoolEQ| ,x ,y))) - -(defconstant |CharCode0| (code-char 0)) - -(defmacro |CharSpace| () '#\Space) -(defmacro |CharNewline| () '#\Newline) -(defmacro |CharMin| () |CharCode0|) -(defmacro |CharMax| () #.(code-char (1- char-code-limit))) -(defmacro |CharIsDigit| (x) `(if (DIGIT-CHAR-P (the |Char| ,x)) 't nil)) -(defmacro |CharIsLetter|(x) `(ALPHA-CHAR-P (the |Char| ,x))) -(defmacro |CharLT| (x y) `(CHAR< (the |Char| ,x) (the |Char| ,y))) -(defmacro |CharLE| (x y) `(CHAR<= (the |Char| ,x) (the |Char| ,y))) -(defmacro |CharEQ| (x y) `(CHAR= (the |Char| ,x) (the |Char| ,y))) -(defmacro |CharNE| (x y) `(CHAR/= (the |Char| ,x) (the |Char| ,y))) -(defmacro |CharLower| (x) `(the |Char| (CHAR-DOWNCASE (the |Char| ,x)))) -(defmacro |CharUpper| (x) `(the |Char| (CHAR-UPCASE (the |Char| ,x)))) -(defmacro |CharOrd| (x) `(CHAR-INT (the |Char| ,x))) -(defmacro |CharNum| (x) `(INT-CHAR (the |SInt| ,x))) - -(defmacro |DFlo0| () (coerce 0 '|DFlo|)) -(defmacro |DFlo1| () (coerce 1 '|DFlo|)) -(defmacro |DFloMin| () BOOT::|$DoubleFloatMinimum|) -(defmacro |DFloMax| () BOOT::|$DoubleFloatMaximum|) -(defmacro |DFloEpsilon| () BOOT::|$DoubleFloatEpsilon|) -(defmacro |DFloIsZero| (x) `(zerop (the |DFlo| ,x))) -(defmacro |DFloIsNeg| (x) `(minusp (the |DFlo| ,x))) -(defmacro |DFloIsPos| (x) `(plusp (the |DFlo| ,x))) -(defmacro |DFloLE| (x y) `(<= (the |DFlo| ,x) (the |DFlo| ,y))) -(defmacro |DFloEQ| (x y) `(= (the |DFlo| ,x) (the |DFlo| ,y))) -(defmacro |DFloLT| (x y) `(< (the |DFlo| ,x) (the |DFlo| ,y))) -(defmacro |DFloNE| (x y) `(/= (the |DFlo| ,x) (the |DFlo| ,y))) -(defmacro |DFloNegate| (x) `(the |DFlo| (- (the |DFlo| ,x)))) -(defmacro |DFloNext| (x) `(the |DFlo| (+ (the |DFlo| ,x) |DFlo1|))) -(defmacro |DFloPrev| (x) `(the |DFlo| (- (the |DFlo| ,x) |DFlo1|))) -(defmacro |DFloPlus| (x y) `(the |DFlo| (+ (the |DFlo| ,x) (the |DFlo| ,y)))) -(defmacro |DFloMinus| (x y) `(the |DFlo| (- (the |DFlo| ,x) (the |DFlo| ,y)))) -(defmacro |DFloTimes| (x y) `(the |DFlo| (* (the |DFlo| ,x) (the |DFlo| ,y)))) -(defmacro |DFloDivide| (x y) `(the |DFlo| (/ (the |DFlo| ,x) (the |DFlo| ,y)))) -(defmacro |DFloTimesPlus| (x y z) - `(the |DFlo| (+ (* (the |DFlo| ,x) (the |DFlo| ,y)) (the |DFlo| ,z)))) - -(defmacro |DFloRPlus| (x y r) `(error "unimplemented operation -- DFloRPlus")) -(defmacro |DFloRMinus| (x y r) `(error "unimplemented operation -- DFloRTimes")) -(defmacro |DFloRTimes| (x y r) `(error "unimplemented operation -- DFloRTimes")) -(defmacro |DFloRTimesPlus| (x y z r) `(error "unimplemented operation -- DFloTimesPlus")) -(defmacro |DFloRDivide|(x y r) `(error "unimplemented operation -- DFloDivide")) - -(defmacro |DFloDissemble| (x) `(error "unimplemented operation -- DFloDissemble")) -(defmacro |DFloAssemble| (w x y z) `(error "unimplemented operation -- DFloAssemble")) - -;; Not builtins anymore -;;(defmacro |DFloRound| (x) `(the |BInt| (round (the |DFlo| ,x)))) -;;(defmacro |DFloTruncate| (x) `(the |BInt| (truncate (the |DFlo| ,x)))) -;;(defmacro |DFloFloor| (x) `(the |BInt| (floor (the |DFlo| ,x)))) -;;(defmacro |DFloCeiling| (x) `(the |BInt| (ceiling (the |DFlo| ,x)))) - -(defmacro |Byte0| () 0) -(defmacro |Byte1| () 1) -(defmacro |ByteMin| () 0) -(defmacro |ByteMax| () 255) - -(defmacro |HInt0| () 0) -(defmacro |HInt1| () 1) -(defmacro |HIntMin| () #.(- (expt 2 15))) -(defmacro |HIntMax| () #.(1- (expt 2 15))) - -(defmacro |SInt0| () 0) -(defmacro |SInt1| () 1) -(defmacro |SIntMin| () `(the |SInt| BOOT::|$ShortMinimum|)) -(defmacro |SIntMax| () `(the |SInt| BOOT::|$ShortMaximum|)) -(defmacro |SIntIsZero| (x) `(zerop (the |SInt| ,x))) -(defmacro |SIntIsNeg| (x) `(minusp (the |SInt| ,x))) -(defmacro |SIntIsPos| (x) `(plusp (the |SInt| ,x))) -(defmacro |SIntIsEven| (x) `(evenp (the |SInt| ,x))) -(defmacro |SIntIsOdd| (x) `(oddp (the |SInt| ,x))) -(defmacro |SIntLE| (x y) `(<= (the |SInt| ,x) (the |SInt| ,y))) -(defmacro |SIntEQ| (x y) `(= (the |SInt| ,x) (the |SInt| ,y))) -(defmacro |SIntLT| (x y) `(< (the |SInt| ,x) (the |SInt| ,y))) -(defmacro |SIntNE| (x y) `(/= (the |SInt| ,x) (the |SInt| ,y))) -(defmacro |SIntNegate| (x) `(the |SInt| (- (the |SInt| ,x)))) -(defmacro |SIntPrev| (x) `(the |SInt| (1- (the |SInt| ,x)))) -(defmacro |SIntNext| (x) `(the |SInt| (1+ (the |SInt| ,x)))) -(defmacro |SIntPlus| (x y) `(the |SInt| (+ (the |SInt| ,x) (the |SInt| ,y)))) -(defmacro |SIntMinus| (x y) `(the |SInt| (- (the |SInt| ,x) (the |SInt| ,y)))) -(defmacro |SIntTimes| (x y) `(the |SInt| (* (the |SInt| ,x) (the |SInt| ,y)))) -(defmacro |SIntTimesPlus| (x y z) - `(the |SInt| (+ (* (the |SInt| ,x) (the |SInt| ,y)) (the |SInt| ,z)))) -(defmacro |SIntMod| (x y) `(the |SInt| (mod(the |SInt| ,x)(the |SInt| ,y)))) -(defmacro |SIntQuo| (x y) - `(the |SInt| (values (truncate (the |SInt| ,x) (the |SInt| ,y))))) -(defmacro |SIntRem| (x y) `(the |SInt| (rem(the |SInt| ,x)(the |SInt| ,y)))) -;;! declare all let variables -(defmacro |SIntDivide| (x y) `(truncate (the |SInt| ,x) (the |SInt| ,y))) -(defmacro |SIntGcd| (x y) `(the |SInt| (gcd (the |SInt| ,x) (the |SInt| ,y)))) - -(defmacro |SIntPlusMod| (a b c) - `(the |SInt| (mod (+ (the |SInt| ,a) (the |SInt| ,b)) (the |SInt| ,c)))) -(defmacro |SIntMinusMod| (a b c) - `(the |SInt| (mod (- (the |SInt| ,a) (the |SInt| ,b)) (the |SInt| ,c)))) -(defmacro |SIntTimesMod| (a b c) - `(the |SInt| (mod (* (the |SInt| ,a) (the |SInt| ,b)) (the |SInt| ,c)))) -;; |SIntTimesModInv| -(defmacro |SIntLength| (x) `(the |SInt| (integer-length (the |SInt| ,x)))) -(defmacro |SIntShiftUp| (x y) `(the |SInt| (ash (the |SInt| ,x) (the |SInt| ,y)))) -(defmacro |SIntShiftDn| (x y) `(the |SInt| (ash (the |SInt| ,x) (the |SInt| (- (the |SInt| ,y)))))) - -(defmacro |SIntBit| (x i) - `(let ((xx ,x) (ii ,i)) (declare (type |SInt| xx ii)) (logbitp ii xx))) -(defmacro |SIntNot| (a) `(the |SInt| (lognot (the |SInt| ,a)))) -(defmacro |SIntAnd| (a b) - `(the |SInt| (logand (the |SInt| ,a) (the |SInt| ,b)))) -(defmacro |SIntOr| (a b) - `(the |SInt| (logior (the |SInt| ,a) (the |SInt| ,b)))) - -;; WordTimesDouble -;; WordDivideDouble -;; WordPlusStep -;; WordTimesStep - -(defmacro |SIntSIPower| (x y) - `(let ((xx ,x) (yy ,y)) - (declare (type |SInt| xx yy)) - (if (minusp yy) (error "cannot raise integers to negative powers") - (the |SInt| (expt xx yy))))) -(defmacro |SIntBIPower| (x y) - `(let ((xx ,x) (yy ,y)) - (declare (type |SInt| xx)) - (declare (type |BInt| yy)) - (if (minusp yy) (error "cannot raise integers to negative powers") - (the |SInt| (expt xx yy))))) - -(defmacro |BInt0| () 0) -(defmacro |BInt1| () 1) -(defmacro |BIntIsZero| (x) `(zerop (the |BInt| ,x))) -(defmacro |BIntIsNeg| (x) `(minusp(the |BInt| ,x))) -(defmacro |BIntIsPos| (x) `(plusp (the |BInt| ,x))) -(defmacro |BIntIsEven| (x) `(evenp (the |BInt| ,x))) -(defmacro |BIntIsOdd| (x) `(oddp (the |BInt| ,x))) -(defmacro |BIntIsSingle| (x) `(typep ,x '|SInt|)) -(defmacro |BIntLE| (x y) `(<= (the |BInt| ,x) (the |BInt| ,y))) -(defmacro |BIntEQ| (x y) `(= (the |BInt| ,x) (the |BInt| ,y))) -(defmacro |BIntLT| (x y) `(< (the |BInt| ,x) (the |BInt| ,y))) -(defmacro |BIntNE| (x y) `(/= (the |BInt| ,x) (the |BInt| ,y))) -(defmacro |BIntNegate| (x) `(the |BInt| (- (the |BInt| ,x)))) -(defmacro |BIntPrev| (x) `(the |BInt| (1- (the |BInt| ,x)))) -(defmacro |BIntNext| (x) `(the |BInt| (1+ (the |BInt| ,x)))) -(defmacro |BIntPlus| (x y) `(the |BInt| (+ (the |BInt| ,x) (the |BInt| ,y)))) -(defmacro |BIntMinus| (x y) `(the |BInt| (- (the |BInt| ,x) (the |BInt| ,y)))) -(defmacro |BIntTimes| (x y) `(the |BInt| (* (the |BInt| ,x) (the |BInt| ,y)))) -(defmacro |BIntTimesPlus| (x y z) - `(the |BInt| (+ (* (the |BInt| ,x) (the |BInt| ,y)) (the |BInt| ,z)))) -(defmacro |BIntMod| (x y) `(the |BInt| (mod(the |BInt| ,x)(the |BInt| ,y)))) -(defmacro |BIntQuo| (x y) - `(the |BInt| (values (truncate (the |BInt| ,x) (the |BInt| ,y))))) -(defmacro |BIntRem| (x y) - `(the |BInt| (rem (the |BInt| ,x) (the |BInt| ,y)))) -(defmacro |BIntDivide| (x y) `(truncate (the |BInt| ,x) (the |BInt| ,y))) -(defmacro |BIntGcd| (x y) - `(the |BInt| (gcd (the |BInt| ,x) (the |BInt| ,y)))) -(defmacro |BIntSIPower| (x y) - `(let ((xx ,x) (yy ,y)) - (declare (type |BInt| xx)) - (declare (type |SInt| yy)) - (if (minusp yy) (error "cannot raise integers to negative powers") - (the |BInt| (expt xx yy))))) -(defmacro |BIntBIPower| (x y) - `(let ((xx ,x) (yy ,y)) - (declare (type |BInt| xx)) - (declare (type |BInt| yy)) - (if (minusp yy) (error "cannot raise integers to negative powers") - (the |BInt| (expt xx yy))))) -(defmacro |BIntLength| (x) `(the |SInt| (integer-length (the |BInt| ,x)))) -(defmacro |BIntShiftUp| (x y) `(the |BInt| (ash (the |BInt| ,x)(the |SInt| ,y)))) -(defmacro |BIntShiftDn| (x y) `(the |BInt| (ash (the |BInt| ,x) (the |SInt| (- (the |SInt| ,y)))))) - -(defmacro |BIntBit| (x i) - `(let ((xx ,x) (ii ,i)) (declare (type |BInt| xx) (type |SInt| ii)) - (logbitp ii xx))) -;;(defmacro |BIntAbs| (x) `(the |BInt| (abs (the |BInt| ,x)))) - -(defmacro |PtrNil| () ()) -(defmacro |PtrIsNil| (x) `(NULL ,x)) -(defmacro |PtrEQ| (x y) `(eq ,x ,y)) -(defmacro |PtrNE| (x y) `(not (eq ,x ,y))) - -;; |WordTimesDouble| |WordDivideDouble| |WordPlusStep| |WordTimesStep| - - -;;(defvar |FoamOutputString| -;; (make-array 80 :element-type 'string-char :adjustable t :fill-pointer 0)) -(defun |FormatNumber| (c arr i) - (let ((str (format nil "~a" c))) - (replace arr str :start1 i) -;; (incf i (fill-pointer |FoamOutputString|)) -;; (if (> i (length arr)) (error "not enough space")) -;; (setf (fill-pointer |FoamOutputString|) 0) - (+ i (length str)))) - -(defmacro |FormatDFlo| (c arr i) `(|FormatNumber| ,c ,arr ,i)) -(defmacro |FormatSInt| (c arr i) `(|FormatNumber| ,c ,arr ,i)) -(defmacro |FormatBInt| (c arr i) `(|FormatNumber| ,c ,arr ,i)) - -(set-syntax-from-char (code-char 0) #\space) ;;makes null char act like white space - -(defmacro |ScanDFlo| (arr i) - `(read-from-string ,arr nil (|DFlo0|) - :start ,i :preserve-whitespace t)) -(defmacro |ScanSInt| (arr i) - `(parse-integer ,arr :start ,i :junk-allowed t)) -(defmacro |ScanBInt| (arr i) - `(parse-integer ,arr :start ,i :junk-allowed t)) - -;; 18/8/93: Evil bug in genfoam---nil generated. -(defmacro hacked-the (type x) - (if x `(the ,type ,x) `(the ,type 0))) - -(defmacro |ByteToSInt| (x) `(coerce (hacked-the |Byte| ,x) '|SInt|)) -(defmacro |BoolToSInt| (x) `(if ,x 1 0)) -(defmacro |BIntToSInt| (x) `(hacked-the |SInt| ,x)) -(defmacro |SIntToBInt| (x) `(hacked-the |BInt| ,x)) -(defmacro |SIntToByte| (x) `(coerce (hacked-the |SInt| ,x) '|Byte|)) -(defmacro |SIntToHInt| (x) `(coerce (hacked-the |SInt| ,x) '|HInt|)) -(defmacro |SIntToDFlo| (x) `(coerce (hacked-the |SInt| ,x) '|DFlo|)) -(defmacro |BIntToDFlo| (x) `(coerce (hacked-the |BInt| ,x) '|DFlo|)) -(defmacro |ArrToDFlo| (x) `(read-from-string ,x nil (|DFlo0|))) -(defmacro |ArrToSInt| (x) `(read-from-string ,x nil (|SInt0|))) -(defmacro |ArrToBInt| (x) `(read-from-string ,x nil (|BInt0|))) - -(defmacro |Clos| (x y) `(let ((xx ,x) (yy #',y)) (cons yy xx))) -(defmacro |ClosFun| (x) `(car ,x)) -(defmacro |ClosEnv| (x) `(cdr ,x)) -(defmacro |SetClosFun| (x y) `(rplaca ,x ,y)) -(defmacro |SetClosEnv| (x y) `(rplacd ,x ,y)) - -(defmacro |MakeEnv| (x y) - `(let ((xx ,x) (yy ,y)) (cons yy (cons xx nil)))) - -(defmacro |EnvLevel| (x) `(car ,x)) -(defmacro |EnvNext| (x) `(cadr ,x)) -(defmacro |EnvInfo| (x) `(if (and (consp ,x) (consp (cdr ,x))) - (cddr ,x) nil)) -(defmacro |SetEnvInfo| (x val) `(rplacd (cdr ,x) ,val)) - -(defmacro |FoamEnvEnsure| (e) - `(if (|EnvInfo| ,e) (|CCall| (|EnvInfo| ,e)) nil)) - -(defconstant null-char-string (string (code-char 0))) -(defmacro |MakeLit| (s) `(concatenate 'string ,s null-char-string)) - -;; functions are represented by symbols, with the symbol-value being some -;; information, and the symbol-function is the function itself. -;; 1-valued lisp should represent progs as either a pair or defstruct. - -(defmacro |FunProg| (x) x) - -(defstruct FoamProgInfoStruct - (funcall nil :type function) - (hashval 0 :type |SInt|)) - -(defun |ProgHashCode| (x) - (let ((aa (foam-function-info x))) - (if (null aa) 0 - (FoamProgInfoStruct-hashval aa)))) - -(defun |SetProgHashCode| (x y) - (let ((aa (foam-function-info x))) - (if (null aa) 0 - (setf (FoamProgInfoStruct-hashval aa) y)))) - -;; In a hurry -> O(n) lookup.. -(defvar foam-function-list ()) - -(defun alloc-prog-info (fun val) - (setq foam-function-list (cons (cons fun val) foam-function-list))) - -(defun foam-function-info (fun) - (let ((xx (assoc fun foam-function-list))) - (if (null xx) nil - (cdr xx)))) - -;; Accessors and constructors -(defmacro |DDecl| (name &rest args) - (setf (get name 'struct-args) args) - `(defstruct ,name ,@(insert-types args))) - -(defun insert-types (slots) - (mapcar #'(lambda (slot) - `(,(car slot) ,(type2init (cadr slot)) - :type ,(cadr slot))) - slots)) - -(defmacro |RNew| (name) - (let* ((struct-args (get name 'struct-args)) - (init-args (mapcar #'(lambda (x) (type2init (cadr x))) - struct-args)) - (count (length struct-args))) - (cond ((> count 2) `(vector ,@init-args)) - ((= count 2) `(cons ,@init-args)) - (t `(list ,@init-args))))) - -(defmacro |RElt| (name field index rec) - (let ((count (length (get name 'struct-args)))) - (cond ((> count 2) `(svref ,rec ,index)) - ((= count 2) - (if (zerop index) `(car ,rec) `(cdr ,rec))) - (t `(car ,rec))))) - -(defmacro |SetRElt| (name field index rec val) - (let ((count (length (get name 'struct-args)))) - (cond ((> count 2) `(setf (svref ,rec ,index) ,val)) - ((= count 2) - (if (zerop index) `(rplaca ,rec ,val) `(rplacd ,rec ,val))) - (t `(rplaca ,rec ,val))))) - -(defmacro |AElt| (name index) - `(aref ,name ,index)) - -(defmacro |SetAElt| (name index val) - `(setf (aref ,name ,index) ,val)) - -(defmacro |MakeLevel| (builder struct) - (if (get struct 'struct-args) - `(,builder) - 'nil)) - - -(defmacro |EElt| (accessor n var) - `(,accessor ,var)) - -(defmacro |SetEElt| (accessor n var val) - `(setf (,accessor ,var) ,val)) - -(defmacro |Lex| (accessor n var) - `(,accessor ,var)) - -(defmacro |SetLex| (accessor n var val) - `(progn ;; (print ',accessor) - (setf (,accessor ,var) ,val))) - -;; Atomic arguments for fun don't need a let to hold the fun. -;; CCall's with arguments need a let to hold the prog and the env. -(defmacro |CCall| (fun &rest args) - (cond ((and (atom fun) (null args)) - `(funcall (|FunProg| (|ClosFun| ,fun)) (|ClosEnv| ,fun))) - ((null args) - `(let ((c ,fun)) - (funcall (|FunProg| (|ClosFun| c)) (|ClosEnv| c)))) - ((atom fun) - `(let ((fun (|FunProg| (|ClosFun| ,fun))) - (env (|ClosEnv| ,fun))) - (funcall fun ,@args env))) - (t - `(let ((c ,fun)) - (let ((fun (|FunProg| (|ClosFun| c))) - (env (|ClosEnv| c))) - (funcall fun ,@args env)))))) - -(defmacro |FoamFree| (o) '()) - -;; macros for defining things - -(defmacro declare-prog (name-result params) - `(proclaim '(function ,(car name-result) ,params ,@(cdr name-result)))) - -(defmacro declare-type (name type) - `(proclaim '(type ,name ,type))) - -(defmacro defprog (type temps &rest body) - `(progn (defun ,(caar type) ,(mapcar #'car (cadr type)) - (typed-let ,temps ,@body)) - (alloc-prog-info #',(caar type) (make-FoamProgInfoStruct)))) - -(defmacro defspecials (&rest lst) - `(proclaim '(special ,@lst))) - -(defmacro top-level-define (&rest junk) - `(setq ,@junk)) - -;; Runtime macros - -;; control transfer -(defmacro block-return (obj val) - `(return-from ,obj ,val)) - -(defmacro typed-let (letvars &rest forms) - `(let ,(mapcar #'(lambda (var) - (list (car var) (type2init (cadr var)))) - letvars ) - (declare ,@(mapcar #'(lambda (var) - (list 'type (cadr var) (car var))) - letvars)) - ,@forms)) - -(defmacro cases (&rest junk) - `(case ,@junk)) - - -;;; Boot macros -(defmacro file-exports (lst) - `(eval-when (load eval) - (when (fboundp 'process-export-entry) - (mapcar #'process-export-entry ,lst)) - nil)) - -(defmacro file-imports (lst) - `(eval-when (load eval) - (when (fboundp 'process-import-entry) - (mapcar #'process-import-entry ,lst)) - nil)) - -(defmacro ignore-var (var) - `(declare (ignore ,var))) - -(defmacro |ANew| (type size) - (if (eq type '|Char|) - `(make-string ,size) - `(make-array ,size - :element-type ',type - :initial-element ,(type2init type)))) - -(defun type2init (x) - (cond - ((eq x '|Char|) '|CharInit|) - ((eq x '|Clos|) '|ClosInit|) - ((eq x '|Bool|) '|BoolInit|) - ((eq x '|Byte|) '|ByteInit|) - ((eq x '|HInt|) '|HIntInit|) - ((eq x '|SInt|) '|SIntInit|) - ((eq x '|BInt|) '|BIntInit|) - ((eq x '|DFlo|) '|DFloInit|) - ((eq x '|Ptr|) '|PtrInit|) - ((eq x '|Word|) '|WordInit|) - ((eq x '|Arr|) '|ArrInit|) - ((eq x '|Record|) '|RecordInit|) - ((eq x '|Arb|) '|ArbInit|) - ((eq x '|Env|) '|EnvInit|) - ((eq x '|Level|) '|LevelInit|) - ((eq x '|Nil|) nil) - (t nil))) - -;; opsys interface -(defvar |G-mainArgc| 0) -(defvar |G-mainArgv| (vector)) -(defmacro |stdinFile| () '*standard-input*) -(defmacro |stdoutFile| () '*standard-output*) -(defmacro |stderrFile| () '*error-output*) - -;; Format functions -;needs to stop when it gets a null character -(defun |strLength| (s) - (dotimes (i (length s)) - (let ((c (schar s i))) - (if (char= c |CharCode0|) - (return i)))) - (length s)) - -(defun |formatSInt| (n) (format nil "~D" n)) -(defun |formatBInt| (n) (format nil "~D" n)) -(defun |formatDFloat| (x) (format nil "~G" x)) - - -;; Printing functions -(defun |printNewLine| (cs) (terpri cs)) -(defun |printChar| (cs c) (princ c cs)) - -;needs to stop when it gets a null character -(defun |printString| (cs s) - (dotimes (i (length s)) - (let ((c (schar s i))) - (if (char= c |CharCode0|) - (return i) - (princ c cs))))) - -(defun |printSInt| (cs n) (format cs "~D" n)) -(defun |printBInt| (cs n) (format cs "~D" n)) -(defun |printDFloat| (cs x) (format cs "~G" x)) - -(defun |fputc| (si cs) - (|printChar| cs (code-char si)) - si) - -(defun |fputs| (s cs) - (|printString| cs s)) - -;; read a string into s starting at pos i1, ending at i2 -;; we should probably macro-out cases where args are constant - -;; fill s[i1..i2] with a null terminated string read from -;; the given input stream -(defun |fgetss| (s i1 i2 f) - (labels ((aux (n) - (if (= n i2) - (progn (setf (schar s n) (code-char 0)) - (- n i1)) - (let ((c (read-char f))) - (setf (schar s n) c) - (if (equal c #\newline) - (progn (setf (char s (+ n 1)) (code-char 0)) - (- n i1)) - (aux (+ n 1))))))) - (aux i1))) - -;; write s[i1..i2) to the output stream f -;; stop on any null characters - -(defun |fputss| (s i1 i2 f) - (labels ((aux (n) - (if (= n i2) (- n i1) - (let ((c (schar s n))) - (if (equal (code-char 0) c) - (- n i1) - (progn (princ c f) - (aux (+ n 1)))))))) - (setq i2 (if (minusp i2) (|strLength| s) - (min i2 (|strLength| s)))) - (aux i1))) - -;; function for compiling and loading from lisp - -(defun compile-as-file (file &optional (opts nil)) - (let* ((path (pathname file)) - (name (pathname-name path)) - (dir (pathname-directory path)) - (type (pathname-type path)) - (lpath (make-pathname :name name :type "l")) - (cpath (make-pathname :name name :type "o"))) - (if (null type) - (setq path (make-pathname :directory dir :name name :type "as"))) - (if opts - (system (format nil "axiomxl ~A -Flsp ~A" opts (namestring path))) - (system (format nil "axiomxl -Flsp ~A" (namestring path)))) - (compile-file (namestring lpath)) - (load (namestring cpath)))) - - -;; given the name of a file (a string), return the name of the AXIOM-XL function -;; that initialises the file. -(defun axiomxl-file-init-name (filename) - (intern (format nil "G-~a" (string-downcase filename)) 'foam-user)) - -;; given the name of the file, id name, and hashcode, return the -;; AXIOM-XL identifier for that object - -(defun axiomxl-global-name (file id hashcode) - (intern (format nil "G-~a_~a_~9,'0d" (string-downcase file) id hashcode) 'foam-user)) - -;; double float elementary functions -(defmacro |sqrt| (x) `(sqrt ,x)) -(defmacro |pow| (a b) `(expt ,a ,b)) -(defmacro |log| (a) `(log ,a)) -(defmacro |exp| (a) `(exp ,a)) - -(defmacro |sin| (a) `(sin ,a)) -(defmacro |cos| (a) `(cos ,a)) -(defmacro |tan| (a) `(tan ,a)) - -(defmacro |sinh| (a) `(sinh ,a)) -(defmacro |cosh| (a) `(cosh ,a)) -(defmacro |tanh| (a) `(tanh ,a)) - -(defmacro |asin| (a) `(asin ,a)) -(defmacro |acos| (a) `(acos ,a)) -(defmacro |atan| (a) `(atan ,a)) -(defmacro |atan2| (a b) `(atan ,a ,b)) - -(defun |Halt| (n) - (error (cond ((= n 101) "System Error: Unfortunate use of dependant type") - ((= n 102) "User error: Reached a 'never'") - ((= n 103) "User error: Bad union branch") - ((= n 104) "User error: Assertion failed") - (t (format nil "Unknown halt condition ~a" n))))) -;; debuging -(defvar *foam-debug-var* nil) -(defun |fiGetDebugVar| () *foam-debug-var*) - -(defun |fiSetDebugVar| (x) (setq *foam-debug-var* x)) -(defun |fiSetDebugger| (x y) ()) -(defun |fiGetDebugger| (x) ()) - -;; Output ports -(defvar |G-stdoutVar| t) -(defvar |G-stdinVar| t) -(defvar |G-stderrVar| t) - -;; !! Not portable !! -;; ??? find a better way to get this work correctly and portably. -#+:GCL -(defun |fiStrHash| (x) (boot::|hashString| (subseq x 0 (- (length x) 1)))) - -;; These three functions check that two cons's contain identical entries. -;; We use EQL to test numbers and EQ everywhere else. If the structure -;; of the two items is different, or any elements are different, we -;; return false. -(defmacro |politicallySound| (u v) - `(or (eql ,u ,v) (eq ,u ,v))) - -(defun |PtrMagicEQ| (u v) -;; I find (as-eg4) that these buggers can be numbers - (cond ( (or (NULL u) (NULL v)) nil) - ( (and (ATOM u) (ATOM v)) (eql u v)) - ( (or (ATOM u) (ATOM v)) nil) -;; removed for Aldor integration -;; ( (equal (length u) (length v)) (|magicEq1| u v)) - (t (eq u v) ))) - -(defun |magicEq1| (u v) - (cond ((and (atom u) (atom v)) - (|politicallySound| u v)) - ((or (atom u) (atom v)) - nil) - ((|politicallySound| (car u) (car v)) - (|magicEq1| (cdr u) (cdr v))))) - - diff --git a/src/interp/i-syscmd.boot b/src/interp/i-syscmd.boot index 1e995c05..fd565e94 100644 --- a/src/interp/i-syscmd.boot +++ b/src/interp/i-syscmd.boot @@ -40,7 +40,7 @@ namespace BOOT $cacheAlist := nil $compileRecurrence := true $errorReportLevel := 'warning -$sourceFileTypes := '(INPUT SPAD BOOT LISP LISP370 META) +$sourceFileTypes := '(INPUT SPAD BOOT LISP) $existingFiles := hashTable "EQUAL" @@ -437,48 +437,21 @@ compiler args == af := pathname args aft := pathnameType af --- Whats this for? MCD/PAB 21-9-95 --- if haveNew and (null(aft) or (aft = '"")) then --- af := pathname [af, '"as"] --- aft = '"as" --- if haveOld and (null(aft) or (aft = '"")) then --- af := pathname [af, '"spad"] --- aft = '"spad" - - haveNew or (aft = '"as") => - not (af1 := $FINDFILE (af, '(as))) => - throwKeyedMsg("S2IL0003",[NAMESTRING af]) - compileAsharpCmd [af1] haveOld or (aft = '"spad") => not (af1 := $FINDFILE (af, '(spad))) => throwKeyedMsg("S2IL0003",[NAMESTRING af]) compileSpad2Cmd [af1] - aft = '"lsp" => - not (af1 := $FINDFILE (af, '(lsp))) => - throwKeyedMsg("S2IL0003",[NAMESTRING af]) - compileAsharpLispCmd [af1] aft = '"NRLIB" => not (af1 := $FINDFILE (af, '(NRLIB))) => throwKeyedMsg("S2IL0003",[NAMESTRING af]) compileSpadLispCmd [af1] - aft = '"ao" => - not (af1 := $FINDFILE (af, '(ao))) => - throwKeyedMsg("S2IL0003",[NAMESTRING af]) - compileAsharpCmd [af1] - aft = '"al" => -- archive library of .ao files - not (af1 := $FINDFILE (af, '(al))) => - throwKeyedMsg("S2IL0003",[NAMESTRING af]) - compileAsharpArchiveCmd [af1] -- see if we something with the appropriate file extension -- lying around af1 := $FINDFILE (af, '(as spad ao asy)) - af1 and pathnameType(af1) = '"as" => compileAsharpCmd [af1] - af1 and pathnameType(af1) = '"ao" => compileAsharpCmd [af1] af1 and pathnameType(af1) = '"spad" => compileSpad2Cmd [af1] - af1 and pathnameType(af1) = '"asy" => compileAsharpArchiveCmd [af1] -- maybe /EDITFILE has some stuff that can help us ef := pathname _/EDITFILE @@ -487,226 +460,16 @@ compiler args == ef = af => throwKeyedMsg("S2IZ0039", nil) af := ef - pathnameType(af) = '"as" => compileAsharpCmd args - pathnameType(af) = '"ao" => compileAsharpCmd args pathnameType(af) = '"spad" => compileSpad2Cmd args -- see if we something with the appropriate file extension -- lying around - af1 := $FINDFILE (af, '(as spad ao asy)) + af1 := $FINDFILE (af, '(spad)) - af1 and pathnameType(af1) = '"as" => compileAsharpCmd [af1] - af1 and pathnameType(af1) = '"ao" => compileAsharpCmd [af1] af1 and pathnameType(af1) = '"spad" => compileSpad2Cmd [af1] - af1 and pathnameType(af1) = '"asy" => compileAsharpArchiveCmd [af1] throwKeyedMsg("S2IZ0039", nil) -compileAsharpCmd args == - compileAsharpCmd1 args - terminateSystemCommand() - -compileAsharpCmd1 args == - -- Assume we entered from the "compiler" function, so args ~= nil - -- and is a file with file extension .as or .ao - - path := pathname args - pathType := pathnameType path - (pathType ~= '"as") and (pathType ~= '"ao") => throwKeyedMsg("S2IZ0083", nil) - null PROBE_-FILE path => throwKeyedMsg("S2IL0003",[namestring args]) - - SETQ(_/EDITFILE, path) - updateSourceFiles path - - optList := '( _ - new _ - old _ - translate _ - onlyargs _ - moreargs _ - quiet _ - nolispcompile _ - noquiet _ - library _ - nolibrary _ - ) - - beQuiet := false -- be verbose here - doLibrary := true -- so a )library after compilation - doCompileLisp := true -- do compile generated lisp code - - moreArgs := nil - onlyArgs := nil - - for opt in $options repeat - [optname,:optargs] := opt - fullopt := selectOptionLC(optname,optList,nil) - - fullopt = 'new => nil - fullopt = 'old => error "Internal error: compileAsharpCmd got )old" - fullopt = 'translate => error "Internal error: compileAsharpCmd got )translate" - - fullopt = 'quiet => beQuiet := true - fullopt = 'noquiet => beQuiet := false - - fullopt = 'nolispcompile => doCompileLisp := false - - fullopt = 'moreargs => moreArgs := optargs - fullopt = 'onlyargs => onlyArgs := optargs - - fullopt = 'library => doLibrary := true - fullopt = 'nolibrary => doLibrary := false - - throwKeyedMsg("S2IZ0036",[strconc('")",object2String optname)]) - - tempArgs := - pathType = '"ao" => - -- want to strip out -Fao - (p := STRPOS('"-Fao", $asharpCmdlineFlags, 0, nil)) => - p = 0 => subString($asharpCmdlineFlags, 5) - strconc(subString($asharpCmdlineFlags, 0, p), '" ", - subString($asharpCmdlineFlags, p+5)) - $asharpCmdlineFlags - $asharpCmdlineFlags - - asharpArgs := - onlyArgs => - s := "" - for a in onlyArgs repeat - s := strconc(s, '" ", object2String a) - s - moreArgs => - s := tempArgs - for a in moreArgs repeat - s := strconc(s, '" ", object2String a) - s - tempArgs - - if not beQuiet then sayKeyedMsg("S2IZ0038A",[namestring args, asharpArgs]) - - command := - strconc(strconc(getEnv('"ALDORROOT"),'"/bin/"),_ - "aldor ", asharpArgs, '" ", namestring args) - rc := runCommand command - - if (rc = 0) and doCompileLisp then - lsp := fnameMake('".", pathnameName args, '"lsp") - if fnameReadable?(lsp) then - if not beQuiet then sayKeyedMsg("S2IZ0089", [namestring lsp]) - compileFileQuietly(lsp) - else - sayKeyedMsg("S2IL0003", [namestring lsp]) - - if rc = 0 and doLibrary then - -- do we need to worry about where the compilation output went? - if not beQuiet then sayKeyedMsg("S2IZ0090", [ pathnameName path ]) - withAsharpCmd [ pathnameName path ] - else if not beQuiet then - sayKeyedMsg("S2IZ0084", nil) - - if not $buildingSystemAlgebra then - extendLocalLibdb $newConlist - -compileAsharpArchiveCmd args == - -- Assume we entered from the "compiler" function, so args ~= nil - -- and is a file with file extension .al. We also assume that - -- the name is fully qualified. - - path := pathname args - null PROBE_-FILE path => throwKeyedMsg("S2IL0003",[namestring args]) - - -- here is the plan: - -- 1. extract the file name and try to make a directory based - -- on that name. - -- 2. cd to that directory and ar x the .al file - -- 3. for each .ao file that shows up, compile it - -- 4. delete the generated .ao files - - -- First try to make the directory in the current directory - - dir := fnameMake('".", pathnameName path, '"axldir") - exists := PROBE_-FILE dir - isDir := directoryp namestring dir - exists and isDir ~= 1=> - throwKeyedMsg("S2IL0027",[namestring dir, namestring args]) - - if isDir ~= 1 then - rc := mkdir namestring dir - rc ~= 0 => throwKeyedMsg("S2IL0027",[namestring dir, namestring args]) - - curDir := GET_-CURRENT_-DIRECTORY() - - -- cd to that directory and try to unarchive the .al file - - cd [ object2Identifier namestring dir ] - - cmd := strconc( '"ar x ", namestring path ) - rc := runCommand cmd - rc ~= 0 => - cd [ object2Identifier namestring curDir ] - throwKeyedMsg("S2IL0028",[namestring dir, namestring args]) - - -- Look for .ao files - - asos := DIRECTORY '"*.ao" - null asos => - cd [ object2Identifier namestring curDir ] - throwKeyedMsg("S2IL0029",[namestring dir, namestring args]) - - -- Compile the .ao files - - for aso in asos repeat - compileAsharpCmd1 [ namestring aso ] - - -- Reset the current directory - - cd [ object2Identifier namestring curDir ] - - terminateSystemCommand() - -compileAsharpLispCmd args == - -- Assume we entered from the "compiler" function, so args ~= nil - -- and is a file with file extension .lsp - - path := pathname args - null PROBE_-FILE path => throwKeyedMsg("S2IL0003",[namestring args]) - - optList := '( _ - quiet _ - noquiet _ - library _ - nolibrary _ - ) - - beQuiet := false -- be verbose here - doLibrary := true -- so a )library after compilation - - for opt in $options repeat - [optname,:optargs] := opt - fullopt := selectOptionLC(optname,optList,nil) - - fullopt = 'quiet => beQuiet := true - fullopt = 'noquiet => beQuiet := false - - fullopt = 'library => doLibrary := true - fullopt = 'nolibrary => doLibrary := false - - throwKeyedMsg("S2IZ0036",[strconc('")",object2String optname)]) - - lsp := fnameMake(pathnameDirectory path, pathnameName path, pathnameType path) - if fnameReadable?(lsp) then - if not beQuiet then sayKeyedMsg("S2IZ0089", [namestring lsp]) - compileFileQuietly(lsp) - else - sayKeyedMsg("S2IL0003", [namestring lsp]) - - if doLibrary then - -- do we need to worry about where the compilation output went? - if not beQuiet then sayKeyedMsg("S2IZ0090", [ pathnameName path ]) - withAsharpCmd [ pathnameName path ] - else if not beQuiet then - sayKeyedMsg("S2IZ0084", nil) - terminateSystemCommand() compileSpadLispCmd args == -- Assume we entered from the "compiler" function, so args ~= nil @@ -870,10 +633,6 @@ compilerDoitWithScreenedLisplib(constructor, fun) == (try compilerDoit(constructor,fun); finally SEQ(UNEMBED 'RWRITE)) -withAsharpCmd args == - $options: local := nil - LOCALDATABASE(args, $options) - --% )copyright -- display copyright notice summary l == diff --git a/src/interp/sys-driver.boot b/src/interp/sys-driver.boot index efa77eba..13742c4e 100644 --- a/src/interp/sys-driver.boot +++ b/src/interp/sys-driver.boot @@ -144,7 +144,6 @@ openDatabases() == OPERATIONOPEN() CATEGORYOPEN() BROWSEOPEN() - CREATE_-INITIALIZERS() ++ restart() == diff --git a/src/interp/util.lisp b/src/interp/util.lisp index 906b661b..b05042e9 100644 --- a/src/interp/util.lisp +++ b/src/interp/util.lisp @@ -1,6 +1,6 @@ ;; Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd. ;; All rights reserved. -;; Copyright (C) 2007-2010, Gabriel Dos Reis. +;; Copyright (C) 2007-2011, Gabriel Dos Reis. ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without @@ -40,10 +40,6 @@ ;; individual files to whole directories. The most complex functions ;; like `makespad' can rebuild the whole algebra tree. -;; A third group of related functions are used to set up the -;; `autoload' mechanism. These enable whole subsystems to -;; be kept out of memory until they are used. - ;; A fourth group of related functions are used to construct and ;; search Emacs TAGS files. @@ -243,79 +239,6 @@ ;; directory from the current {\bf AXIOM} shell variable. (defvar $relative-library-directory-list '("/algebra/")) -;; This is part of the {\bf ALDOR subsystem}. These will be loaded -;; if you compile a {\bf .as} file rather than a {\bf .spad} file. -;; {\bf ALDOR} is an external compiler that gets automatically called -;; if the file extension is {\bf .as}. -(defparameter asauto-functions '( - loadas -;; |as| ;; now in as.boot -;; |astran| ;; now in as.boot - |spad2AxTranslatorAutoloadOnceTrigger| - |sourceFilesToAxcliqueAxFile| - |sourceFilesToAxFile| - |setExtendedDomains| - |makeAxFile| - |makeAxcliqueAxFile| - |nrlibsToAxFile| - |attributesToAxFile| )) - -;; These are some {\bf debugging} functions that I use. I can't imagine -;; why you might autoload them but they don't need to be in a running -;; system. -(defparameter debug-functions '( - loaddebug - |showSummary| - |showPredicates| - |showAttributes| - |showFrom| - |showImp|)) - -;; This function is called by {\bf build-interpsys}. It takes two lists. -;; The first is a list of functions that need to be used as -;; ``autoload triggers''. The second is a list of files to load if one -;; of the trigger functions is called. At system build time each of the -;; functions in the first list is set up to load every file in the second -;; list. In this way we will automatically load a whole subsystem if we -;; touch any function in that subsystem. We call a helper function -;; called {\bf setBootAutoLoadProperty} to set up the autoload trigger. -;; This helper function is listed below. -(defun |setBootAutloadProperties| (fun-list file-list) -#+:AKCL - (mapc #'(lambda (fun) (|setBootAutoLoadProperty| fun file-list)) fun-list) -) - - -;; This function knows where the {\bf autoload} subdirectory lives. -;; It is called by {\bf mkBootAutoLoad} above to find the necessary -;; files. -(defun boot-load (file) - (let ((name (concat (|systemRootDirectory|) - "/autoload/" - (pathname-name file)))) - (if |$printLoadMsgs| - (format t " Loading ~A.~%" name)) - (load name))) - -;; This is a helper function to set up the autoload trigger. It sets -;; the function cell of each symbol to {\bf mkBootAutoLoad} which is -;; listed below. -(defun |setBootAutoLoadProperty| (func file-list) - (setf (symbol-function func) (|mkBootAutoLoad| func file-list)) ) - -;; This is how the autoload magic happens. Every function named in the -;; autoload lists is actually just another name for this function. When -;; the named function is called we call {\bf boot-load} on all of the -;; files in the subsystem. This overwrites all of the autoload triggers. -;; We then look up the new (real) function definition and call it again -;; with the real arguments. Thus the subsystem loads and the original -;; call succeeds. -(defun |mkBootAutoLoad| (fn file-list) - (function (lambda (&rest args) - (mapc #'boot-load file-list) - (unless (string= (subseq (string fn) 0 4) "LOAD") - (apply (symbol-function fn) args))))) - ;############################################################################ ;# autoload dependencies ;# @@ -332,23 +255,15 @@ ;# (e.g. ${AUTO}/parsing.${O}: ${OUT}/parsing.${O}) ;# c) edit util.lisp to add the 'external' function (those that ;# should trigger the autoload -;# case 2: -;# build-interpsys (in util.lisp) needs an extra argument for the -;# new autoload things and several functions in util.lisp need hacking. ;############################################################################ -;; The `build-interpsys' function takes a list of files to load -;; into the image (`load-files'). It also takes several lists of files, -;; one for each subsystem which will be autoloaded. Autoloading is explained -;; below. This function is called in the src/interp/Makefile. - ;; This function calls `reroot' to set up pathnames we need. Next ;; it sets up the lisp system memory (at present only for AKCL/GCL). Next ;; it loads all of the named files, resets a few global state variables, ;; loads the databases, sets up autoload triggers and clears out hash tables. ;; After this function is called the image is clean and can be saved. -(defun build-interpsys (asauto-files) +(defun build-interpsys () (reroot) (|resetWorkspaceVariables|) (|AxiomCore|::|%sysInit|) @@ -357,10 +272,8 @@ (|initNewWorld|) (compressopen) (interpopen) - (create-initializers) (|start| :fin) (setq *load-verbose* nil) - (|setBootAutloadProperties| asauto-functions asauto-files) (|fillDatabasesInCore|) ; the databases into core, then close the streams (|closeAllDatabaseStreams|) ) |