aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authordos-reis <gdr@axiomatics.org>2011-06-21 18:51:36 +0000
committerdos-reis <gdr@axiomatics.org>2011-06-21 18:51:36 +0000
commit8b45d02f8f861fe0eab071ccbfcf5ef8bd6593d6 (patch)
tree8d3c3bb0bdc0ce060e3a622704b6f04709dfcd1c
parent4e5497862c2e37f86114b21f03e443072ec6abf0 (diff)
downloadopen-axiom-8b45d02f8f861fe0eab071ccbfcf5ef8bd6593d6.tar.gz
1 * interp/Makefile.in (OBJS): Remove foam_l.$(FASLEXT), $(ASCOMP).
(ASCOMP, ASAUTO): Remove. * interp/axext_l.lisp: Remove. * interp/foam_l.lisp: Likewise. * interp/ax.boot: Likewise. * interp/as.boot: Likewise. * interp/daase.lisp: Adjust. * interp/i-syscmd.boot: Likewise.
Diffstat
-rw-r--r--src/ChangeLog11
-rw-r--r--src/interp/Makefile.in27
-rw-r--r--src/interp/as.boot1190
-rw-r--r--src/interp/ax.boot385
-rw-r--r--src/interp/axext_l.lisp208
-rw-r--r--src/interp/daase.lisp344
-rw-r--r--src/interp/foam_l.lisp842
-rw-r--r--src/interp/i-syscmd.boot245
-rw-r--r--src/interp/sys-driver.boot1
-rw-r--r--src/interp/util.lisp91
10 files changed, 28 insertions, 3316 deletions
diff --git a/src/ChangeLog b/src/ChangeLog
index 0aad1b5a..c0e20a55 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,5 +1,16 @@
2011-06-21 Gabriel Dos Reis <gdr@cs.tamu.edu>
+ * interp/Makefile.in (OBJS): Remove foam_l.$(FASLEXT), $(ASCOMP).
+ (ASCOMP, ASAUTO): Remove.
+ * interp/axext_l.lisp: Remove.
+ * interp/foam_l.lisp: Likewise.
+ * interp/ax.boot: Likewise.
+ * interp/as.boot: Likewise.
+ * interp/daase.lisp: Adjust.
+ * interp/i-syscmd.boot: Likewise.
+
+2011-06-21 Gabriel Dos Reis <gdr@cs.tamu.edu>
+
* interp/buildom.boot (MappingCategory): Take argument by value.
2011-06-21 Gabriel Dos Reis <gdr@cs.tamu.edu>
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|)
)
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-28 16:26:31 +0000