diff --git a/changelog b/changelog index 920f6c5..a92ed95 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,7 @@ +20090830 tpd src/axiom-website/patches.html 20090830.04.tpd.patch +20090830 tpd src/interp/Makefile move as.boot to as.lisp +20090830 tpd src/interp/as.lisp added, rewritten from as.boot +20090830 tpd src/interp/as.boot removed, rewritten to as.lisp 20090830 tpd src/axiom-website/patches.html 20090830.03.tpd.patch 20090830 tpd src/interp/Makefile move hashcode.boot to hashcode.lisp 20090830 tpd src/interp/hashcode.lisp added, rewritten from hashcode.boot diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 894fbd0..40c43dc 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -1944,5 +1944,7 @@ src/interp/br-con rewrite from boot to lisp
src/interp/bc-matrix rewrite from boot to lisp
20090830.03.tpd.patch src/interp/hashcode rewrite from boot to lisp
+20090830.04.tpd.patch +src/interp/as.lisp rewrite from boot to lisp
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index 0c48c5e..6622785 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -3316,34 +3316,26 @@ ${MID}/termrw.lisp: ${IN}/termrw.lisp.pamphlet @ -\subsection{as.boot} +\subsection{as.lisp} <>= -${OUT}/as.${O}: ${MID}/as.clisp - @ echo 416 making ${OUT}/as.${O} from ${MID}/as.clisp - @ (cd ${MID} ; \ +${OUT}/as.${O}: ${MID}/as.lisp + @ echo 136 making ${OUT}/as.${O} from ${MID}/as.lisp + @ ( cd ${MID} ; \ if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/as.clisp"' \ - ':output-file "${OUT}/as.${O}") (${BYE}))' | ${DEPSYS} ; \ + echo '(progn (compile-file "${MID}/as.lisp"' \ + ':output-file "${OUT}/as.${O}") (${BYE}))' | ${DEPSYS} ; \ else \ - echo '(progn (compile-file "${MID}/as.clisp"' \ - ':output-file "${OUT}/as.${O}") (${BYE}))' | ${DEPSYS} \ + echo '(progn (compile-file "${MID}/as.lisp"' \ + ':output-file "${OUT}/as.${O}") (${BYE}))' | ${DEPSYS} \ >${TMP}/trace ; \ fi ) @ -<>= -${MID}/as.clisp: ${IN}/as.boot.pamphlet - @ echo 417 making ${MID}/as.clisp from ${IN}/as.boot.pamphlet +<>= +${MID}/as.lisp: ${IN}/as.lisp.pamphlet + @ echo 137 making ${MID}/as.lisp from ${IN}/as.lisp.pamphlet @ (cd ${MID} ; \ - ${TANGLE} ${IN}/as.boot.pamphlet >as.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "as.boot") (${BYE}))' \ - | ${DEPSYS} ; \ - else \ - echo '(progn (boottran::boottocl "as.boot") (${BYE}))' \ - | ${DEPSYS} >${TMP}/trace ; \ - fi ; \ - rm as.boot ) + ${TANGLE} ${IN}/as.lisp.pamphlet >as.lisp ) @ @@ -4489,7 +4481,7 @@ clean: <> <> -<> +<> <> <> diff --git a/src/interp/as.boot.pamphlet b/src/interp/as.boot.pamphlet deleted file mode 100644 index ddeb12f..0000000 --- a/src/interp/as.boot.pamphlet +++ /dev/null @@ -1,1217 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp as.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{New Aldor compiler changes} -This mod is used to make the open source version of Axiom work -with the new aldor compiler. -Aldor does not want the [[attributeAlist]]. -This used to read: -\begin{verbatim} - HPUT($opHash,con,[ancestorAlist,attributeAlist,:opalist]) -\end{verbatim} -but was changed to: -<>= - HPUT($opHash,con,[ancestorAlist,nil,:opalist]) -@ -\section{License} -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - ---global hash tables for new compiler -$docHash := MAKE_-HASH_-TABLE() -$conHash := MAKE_-HASH_-TABLE() -$opHash := MAKE_-HASH_-TABLE() -$asyPrint := false - -asList() == - OBEY '"rm -f temp.text" - OBEY '"ls as/*.asy > temp.text" - instream := OPEN '"temp.text" - lines := [READLINE instream while not EOFP instream] - CLOSE instream - lines - -asAll lines == - for x in lines repeat - sayBrightly ['"-----> ",x] - asTran x - 'done - -as name == - astran STRCONC(STRINGIMAGE name,'".asy") --- astran STRCONC(getEnv('"AXIOM"), --- '"/../../obj/rios/as/",STRINGIMAGE name,'".asy") - 'done - -astran asyFile == ---global hash tables for new compiler - $docHash := MAKE_-HASH_-TABLE() - $conHash := MAKE_-HASH_-TABLE() - $constantHash := MAKE_-HASH_-TABLE() - $niladics : local := nil - $asyFile: local := asyFile - $asFilename: local := STRCONC(PATHNAME_-NAME asyFile,'".as") - asytran asyFile - conlist := [x for x in HKEYS $conHash | HGET($conHash,x) isnt [.,.,"function",:.]] - $mmAlist : local := - [[con,:asyConstructorModemap con] for con in conlist] - $docAlist : local := - [[con,:REMDUP asyDocumentation con] for con in conlist] - $parentsHash : local := MAKE_-HASH_-TABLE() ---$childrenHash: local := MAKE_-HASH_-TABLE() - for con in conlist repeat - parents := asyParents con - HPUT($parentsHash,con,asyParents con) --- for [parent,:pred] in parents repeat --- parentOp := opOf parent --- HPUT($childrenHash,parentOp,insert([con,:pred],HGET($childrenHash,parentOp))) - $newConlist := UNION(conlist, $newConlist) - [[x,:asMakeAlist x] for x in HKEYS $conHash] - -asyParents(conform) == - acc := nil - con:= opOf conform ---formals := TAKE(#formalParams,$TriangleVariableList) - modemap := LASSOC(con,$mmAlist) - $constructorCategory :local := asySubstMapping CADAR modemap - for x in folks $constructorCategory repeat --- x := SUBLISLIS(formalParams,formals,x) --- x := SUBLISLIS(IFCDR conform,formalParams,x) --- x := SUBST('Type,'Object,x) - acc := [:explodeIfs x,:acc] - NREVERSE acc - -asySubstMapping u == - u is [op,:r] => - op = "->" => - [s, t] := r - args := - s is [op,:u] and asyComma? op => [asySubstMapping y for y in u] - [asySubstMapping s] - ['Mapping, asySubstMapping t, :args] - [asySubstMapping x for x in u] - u - ---asyFilePackage asyFile == --- name := INTERN PATHNAME_-NAME asyFile --- modemap := --- [[[name],['CATEGORY,'domain, --- :[asyMkSignature(con,CDAR mm) for [con,:mm] in $mmAlist]]],['T,name]] --- opAlist := [[con,[CDAR mm]] for [con,:mm] in $mmAlist] --- documentation := --- [[con,[CDAR mm,fn LASSOC(con,$docAlist)]] for [con,:mm] in $mmAlist] --- where fn u == --- LASSOC('constructor,u) is [[=nil,doc]] => doc --- '"" --- res := [['constructorForm,name],['constant,:'true], --- ['constructorKind,:'file], --- ['constructorModemap,:modemap], --- ['sourceFile,:PNAME name], --- ['operationAlist,:zeroOneConversion opAlist], --- ['documentation,:documentation]] ---asyDisplay(name,res) --- [name,:res] - -asyMkSignature(con,sig) == --- atom sig => ['TYPE,con,sig] --- following line converts constants into nullary functions - atom sig => ['SIGNATURE,con,[sig]] - ['SIGNATURE,con,sig] - -asMakeAlist con == - record := HGET($conHash,con) - [form,sig,predlist,kind,exposure,comments,typeCode,:filename] := first record ---TTT in case we put the wrong thing in for niladic catgrs ---if ATOM(form) and kind='category then form:=[form] - if ATOM(form) then form:=[form] - kind = 'function => asMakeAlistForFunction con - abb := asyAbbreviation(con,#(KDR sig)) - if null KDR form then PUT(opOf form,'NILADIC,'T) - modemap := asySubstMapping LASSOC(con,$mmAlist) - $constructorCategory :local := CADAR modemap - parents := mySort HGET($parentsHash,con) ---children:= mySort HGET($childrenHash,con) - alists := HGET($opHash,con) - opAlist := SUBLISLIS($FormalMapVariableList,KDR form,CDDR alists) - ancestorAlist:= SUBLISLIS($FormalMapVariableList,KDR form,CAR alists) - catAttrs := [[x,:true] for x in getAttributesFromCATEGORY $constructorCategory] - attributeAlist := REMDUP [:CADR alists,:catAttrs] - documentation := - SUBLISLIS($FormalMapVariableList,KDR form,LASSOC(con,$docAlist)) - filestring := STRCONC(PATHNAME_-NAME STRINGIMAGE filename,'".as") - constantPart := HGET($constantHash,con) and [['constant,:true]] - niladicPart := MEMQ(con,$niladics) and [['NILADIC,:true]] - falist := TAKE(#KDR form,$FormalMapVariableList) - constructorCategory := - kind = 'category => - talist := TAKE(#KDR form, $TriangleVariableList) - SUBLISLIS(talist, falist, $constructorCategory) - SUBLISLIS(falist,KDR form,$constructorCategory) - if constructorCategory='Category then kind := 'category - exportAlist := asGetExports(kind, form, constructorCategory) - constructorModemap := SUBLISLIS(falist,KDR form,modemap) ---TTT fix a niladic category constructormodemap (remove the joins) - if kind = 'category then - SETF(CADAR(constructorModemap),['Category]) - res := [['constructorForm,:form],:constantPart,:niladicPart, - ['constructorKind,:kind], - ['constructorModemap,:constructorModemap], - ['abbreviation,:abb], - ['constructorCategory,:constructorCategory], - ['parents,:parents], - ['attributes,:attributeAlist], - ['ancestors,:ancestorAlist], - -- ['children,:children], - ['sourceFile,:filestring], - ['operationAlist,:zeroOneConversion opAlist], - ['modemaps,:asGetModemaps(exportAlist,form,kind,modemap)], - ['sourcefile,:$asFilename], - ['typeCode,:typeCode], - ['documentation,:documentation]] - if $asyPrint then asyDisplay(con,res) - res - -asGetExports(kind, conform, catform) == - u := asCategoryParts(kind, conform, catform, true) or return nil - -- ensure that signatures are lists - [[op, sigpred] for [op,sig,:pred] in CDDR u] where - sigpred == - pred := - pred = "T" => nil - pred - [sig, nil, :pred] - -asMakeAlistForFunction fn == - record := HGET($conHash,fn) - [form,sig,predlist,kind,exposure,comments,typeCode,:filename] := first record - modemap := LASSOC(fn,$mmAlist) - newsig := asySignature(sig,nil) - opAlist := [[fn,[newsig,nil,:predlist]]] - res := [['modemaps,:asGetModemaps(opAlist,fn,'function,modemap)], - ['typeCode,:typeCode]] - if $asyPrint then asyDisplay(fn,res) - res - -getAttributesFromCATEGORY catform == - catform is ['CATEGORY,.,:r] => [y for x in r | x is ['ATTRIBUTE,y]] - catform is ['Join,:m,x] => getAttributesFromCATEGORY x - nil - -displayDatabase x == main where - main == - for y in - '(CONSTRUCTORFORM CONSTRUCTORKIND _ - CONSTRUCTORMODEMAP _ - ABBREVIATION _ - CONSTRUCTORCATEGORY _ - PARENTS _ - ATTRIBUTES _ - ANCESTORS _ - SOURCEFILE _ - OPERATIONALIST _ - MODEMAPS _ - SOURCEFILE _ - DOCUMENTATION) repeat fn(x,y) - fn(x,y) == - sayBrightly ['"----------------- ",y,'" --------------------"] - pp GETDATABASE(x,y) - --- For some reason Dick has modified as.boot to convert the --- identifier |0| or |1| to an integer in the list of operations. --- This is WRONG, all existing code assumes that operation names --- are always identifiers not numbers. --- This function breaks the ability of the interpreter to find --- |0| or |1| as exports of new compiler domains. --- Unless someone has a strong reason for keeping the change, --- this function should be no-opped, i.e. --- zeroOneConversion opAlist == opAlist --- If this change is made, then we are able to find asharp constants again. --- bmt Mar 26, 1994 and executed by rss - -zeroOneConversion opAlist == opAlist --- for u in opAlist repeat --- [op,:.] := u --- DIGITP (PNAME op).0 => RPLACA(u, string2Integer PNAME op) --- opAlist - -asyDisplay(con,alist) == - banner := '"==============================" - sayBrightly [banner,'" ",con,'" ",banner] - for [prop,:value] in alist repeat - sayBrightlyNT [prop,'": "] - pp value - -asGetModemaps(opAlist,oform,kind,modemap) == - acc:= nil - rpvl:= - MEMQ(kind, '(category function)) => rest $PatternVariableList -- *1 is special for $ - $PatternVariableList - form := [opOf oform,:[y for x in KDR oform for y in rpvl]] - dc := - MEMQ(kind, '(category function)) => "*1" - form - pred1 := - kind = 'category => [["*1",form]] - nil - signature := CDAR modemap - domainList := - [[a,m] for a in rest form for m in rest signature | - asIsCategoryForm m] - catPredList:= - kind = 'function => [["isFreeFunction","*1",opOf form]] - [['ofCategory,:u] for u in [:pred1,:domainList]] --- for [op,:itemlist] in SUBLISLIS(rpvl, $FormalMapVariableList,opAlist) repeat --- the code seems to oscillate between generating $FormalMapVariableList --- and generating $TriangleVariableList - for [op,:itemlist] in SUBLISLIS(rpvl, $FormalMapVariableList,opAlist) repeat - for [sig0, pred] in itemlist repeat - sig := SUBST(dc,"$",sig0) - pred:= SUBST(dc,"$",pred) - sig := SUBLISLIS(rpvl,KDR oform,sig) - pred:= SUBLISLIS(rpvl,KDR oform,pred) - pred := pred or 'T - ----------> Constants change <-------------- - if IDENTP sig0 then - sig := [sig] - pred := MKPF([pred,'(isAsConstant)],'AND) - pred' := MKPF([pred,:catPredList],'AND) - mm := [[dc,:sig],[pred']] - acc := [[op,:interactiveModemapForm mm],:acc] - NREVERSE acc - -asIsCategoryForm m == - m = 'BasicType or GETDATABASE(opOf m,'CONSTRUCTORKIND) = 'category - -asyDocumentation con == - docHash := HGET($docHash,con) - u := [[op,:[fn(x,op) for x in rec]] for op in HKEYS docHash - | rec := HGET(docHash,op)] where fn(x,op) == - [form,sig,pred,origin,where?,comments,:.] := x - ----------> Constants change <-------------- - if IDENTP sig then sig := [sig] - [asySignature(sig,nil),trimComments comments] - [form,sig,pred,origin,where?,comments] := first HGET($conHash,con) - --above "first" assumes only one entry - comments := trimComments asyExtractDescription comments - [:u,['constructor,[nil,comments]]] - -asyExtractDescription str == - k := STRPOS('"Description:",str,0,nil) => asyExtractDescription SUBSTRING(str,k + 12,nil) - k := STRPOS('"Author:",str,0,nil) => asyExtractDescription SUBSTRING(str,0,k) - str - -trimComments str == - null str or str = '"" => '"" - m := MAXINDEX str - str := SUBSTRING(str,0,m) - trimString str - -asyExportAlist con == ---format of 'operationAlist property of LISPLIBS (as returned from koOps): --- --- ---!!! asyFile NEED: need to know if function is implemented by domain!!! - docHash := HGET($docHash,con) - [[op,:[fn(x,op) for x in rec]] for op in HKEYS docHash | rec := HGET(docHash,op)] - where fn(x,op) == - [form,sig,pred,origin,where?,comments,:.] := x - tail := - pred => [pred] - nil - newSig := asySignature(sig,nil) - [newSig,nil,:tail] - -asyMakeOperationAlist(con,proplist, key) == - oplist := - u := LASSOC('domExports,proplist) => - kind := 'domain - u - u := LASSOC('catExports,proplist) => - kind := 'category - u - key = 'domain => - kind := 'domain - u := NIL - return nil - ht := MAKE_-HASH_-TABLE() - ancestorAlist := nil - for ['Declare,id,form,r] in oplist repeat - id = "%%" => - opOf form = con => nil - y := asyAncestors form - [attrs, na] := asyFindAttrs y - y := na - if opOf(y)^=con then ancestorAlist := [ [y,:true],:ancestorAlist] - idForm := - form is ['Apply,'_-_>,source,target] => [id,:asyArgs source] - ----------> Constants change <-------------- - id - pred := - LASSOC('condition,r) is p => hackToRemoveAnd p - nil - sig := asySignature(asytranForm(form,[idForm],nil),nil) - entry := - --id ^= "%%" and IDENTP idForm => [[sig],nil,nil,'ASCONST] - id ^= "%%" and IDENTP idForm => - pred => [[sig],nil,asyPredTran pred,'ASCONST] - [[sig],nil,true,'ASCONST] - pred => [sig,nil,asyPredTran pred] - [sig] - HPUT(ht,id,[entry,:HGET(ht,id)]) - opalist := [[op,:REMDUP HGET(ht,op)] for op in HKEYS ht] - --HPUT($opHash,con,[ancestorAlist,attributeAlist,:opalist]) -<> - -hackToRemoveAnd p == ----remove this as soon as .asy files do not contain forms (And pred) forms - p is ['And,q,:r] => - r => ['AND,q,:r] - q - p - -asyAncestors x == - x is ['Apply,:r] => asyAncestorList r - x is [op,y,:.] and MEMQ(op, '(PretendTo RestrictTo)) => asyAncestors y - atom x => - x = '_% => '_$ - MEMQ(x, $niladics) => [x] - GETDATABASE(x ,'NILADIC) => [x] - x - asyAncestorList x - -asyAncestorList x == [asyAncestors y for y in x] ---============================================================================ --- Build Operation Alist from sig ---============================================================================ - ---format of operations as returned from koOps --- --- - ---abb,kind,file,sourcefile,coSig,dbLineNumber,constructorArgs,libfile ---((sig where(NIL or #) condition(T or pred) ELTorSubsumed) ... ---expanded lists are: sig, predicate, origin, exposeFlag, comments - ---============================================================================ --- Building Hash Tables for Operations/Constructors ---============================================================================ -asytran fn == ---put operations into table format for browser: --- - inStream := OPEN fn - sayBrightly ['" Reading ",fn] - u := READ inStream - $niladics := mkNiladics u - for x in $niladics repeat PUT(x,'NILADIC,true) - for d in u repeat - ['Declare,name,:.] := d - name = "%%" => 'skip --skip over top-level properties - $docHashLocal: local := MAKE_-HASH_-TABLE() - asytranDeclaration(d,'(top),nil,false) - if null name then hohohoho() - HPUT($docHash,name,$docHashLocal) - CLOSE inStream - 'done - -mkNiladics u == - [name for x in u | x is ['Declare,name,y,:.] and y isnt ['Apply,'_-_>,:.]] - ---OLD DEFINITION FOLLOWS -asytranDeclaration(dform,levels,predlist,local?) == - ['Declare,id,form,r] := dform - id = 'failed => id - KAR dform ^= 'Declare => systemError '"asytranDeclaration" - if levels = '(top) then - if form isnt ['Apply,"->",:.] then HPUT($constantHash,id,true) - comments := LASSOC('documentation,r) or '"" - idForm := - levels is ['top,:.] => - form is ['Apply,'_-_>,source,target] => [id,:asyArgs source] - id - ----------> Constants change <-------------- - id - newsig := asytranForm(form,[idForm,:levels],local?) - key := - levels is ['top,:.] => - MEMQ(id,'(%% Category Type)) => 'constant - asyLooksLikeCatForm? form => 'category - form is ['Apply, '_-_>,.,u] => - if u is ['Apply, construc,:.] then u:= construc - GETDATABASE(opOf u,'CONSTRUCTORKIND) = 'domain => 'function - asyLooksLikeCatForm? u => 'category - 'domain - 'domain - first levels - typeCode := LASSOC('symeTypeCode,r) - record := [idForm,newsig,asyMkpred predlist,key,true,comments,typeCode,:$asyFile] - if not local? then - ht := - levels = '(top) => $conHash - $docHashLocal - HPUT(ht,id,[record,:HGET(ht,id)]) - if levels = '(top) then asyMakeOperationAlist(id,r, key) - ['Declare,id,newsig,r] - -asyLooksLikeCatForm? x == ---TTT don't see a Third in my version .... - x is ['Define, ['Declare, ., ['Apply, 'Third,:.],:.],:.] or - x is ['Define, ['Declare, ., 'Category ],:.] - ---asytranDeclaration(dform,levels,predlist,local?) == --- ['Declare,id,form,r] := dform --- id = 'failed => id --- levels isnt ['top,:.] => asytranForm(form,[id,:levels],local?) --- idForm := --- form is ['Apply,'_-_>,source,target] => [id,:asyArgs source] --- id --- if form isnt ['Apply,"->",:.] then HPUT($constantHash,id,true) --- comments := LASSOC('documentation,r) or '"" --- newsig := asytranForm(form,[idForm,:levels],local?) --- key := --- MEMQ(id,'(%% Category Type)) => 'constant --- form is ['Apply,'Third,:.] => 'category --- form is ['Apply,.,.,target] and target is ['Apply,name,:.] --- and MEMQ(name,'(Third Join)) => 'category --- 'domain --- record := [newsig,asyMkpred predlist,key,true,comments,:$asyFile] --- if not local? then --- ht := --- levels = '(top) => $conHash --- $docHashLocal --- HPUT(ht,id,[record,:HGET(ht,id)]) --- if levels = '(top) then asyMakeOperationAlist(id,r) --- ['Declare,id,newsig,r] - -asyIsCatForm form == - form is ['Apply,:r] => - r is ['_-_>,.,a] => asyIsCatForm a - r is ['Third,'Type,:.] => true - false - false - -asyArgs source == - args := - source is [op,:u] and asyComma? op => u - [source] - [asyArg x for x in args] - -asyArg x == - x is ['Declare,id,:.] => id - x - -asyMkpred predlist == - null predlist => nil - predlist is [p] => p - ['AND,:predlist] - -asytranForm(form,levels,local?) == - u := asytranForm1(form,levels,local?) - null u => hahah() - u - -asytranForm1(form,levels,local?) == - form is ['With,left,cat] => --- left ^= nil => error '"WITH cannot take a left argument yet" - asytranCategory(form,levels,nil,local?) - form is ['Apply,:.] => asytranApply(form,levels,local?) - form is ['Declare,:.] => asytranDeclaration(form,levels,nil,local?) - form is ['Comma,:r] => ['Comma,:[asytranForm(x,levels,local?) for x in r]] ---form is ['_-_>,:s] => asytranMapping(s,levels,local?) - form is [op,a,b] and MEMQ(a,'(PretendTo RestrictTo)) => - asytranForm1(a,levels,local?) - form is ['LitInteger,s] => - READ_-FROM_-STRING(s) - form is ['Define,:.] => - form is ['Define,['Declare,.,x,:.],rest] => ---TTT i don't know about this one but looks ok - x = 'Category => asytranForm1(rest,levels, local?) - asytranForm1(x,levels,local?) - error '"DEFINE forms are not handled yet" - if form = '_% then $hasPerCent := true - IDENTP form => - form = "%" => "$" - GET(form,'NILADIC) => [form] - form - [asytranForm(x,levels,local?) for x in form] - -asytranApply(['Apply,name,:arglist],levels,local?) == - MEMQ(name,'(Record Union)) => - [name,:[asytranApplySpecial(x, levels, local?) for x in arglist]] - null arglist => [name] - name is [ 'RestrictTo, :.] => - asytranApply(['Apply, CAR CDR name,:arglist], levels, local?) - name is [ 'Qualify, :.] => - asytranApply(['Apply, CAR CDR name,:arglist], levels, local?) - name is 'string => asytranLiteral CAR arglist - name is 'integer => asytranLiteral CAR arglist - name is 'float => asytranLiteral CAR arglist - name = 'Enumeration => - ["Enumeration",:[asytranEnumItem arg for arg in arglist]] - [:argl,lastArg] := arglist - [name,:[asytranFormSpecial(arg,levels,true) for arg in argl], - asytranFormSpecial(lastArg,levels,false)] - -asytranLiteral(lit) == - CAR CDR lit - -asytranEnumItem arg == - arg is ['Declare, name, :.] => name - error '"Bad Enumeration entry" - -asytranApplySpecial(x, levels, local?) == - x is ['Declare, name, typ, :.] => [":",name,asytranForm(typ, levels, local?)] - asytranForm(x, levels, local?) - -asytranFormSpecial(x, levels, local?) == --> this throws away variable name (revise later) - x is ['Declare, name, typ, :.] => asytranForm(typ, levels, local?) - asytranForm(x, levels, local?) - -asytranCategory(form,levels,predlist,local?) == - cat := - form is ['With,left,right] => - right is ['Blank,:.] => ['Sequence] - right - form - left := - form is ['With,left,right] => - left is ['Blank,:.] => nil - left - nil - $hasPerCent: local := nil - items := - cat is ['Sequence,:s] => s - [cat] - catTable := MAKE_-HASH_-TABLE() - catList := nil - for x in items | x repeat - if null x then systemError() - dform := asytranCategoryItem(x,levels,predlist,local?) - null dform => nil - dform is ['Declare,id,record,r] => - HPUT(catTable,id,[asyWrap(record,predlist),:HGET(catTable,id)]) - catList := [asyWrap(dform,predlist),:catList] - keys := listSort(function GLESSEQP,HKEYS catTable) - right1 := NREVERSE catList - right2 := [[key,:HGET(catTable,key)] for key in keys] - right := - right2 => [:right1,['Exports,:right2]] - right1 - res := - left => [left,:right] - right - res is [x] and x is ['IF,:.] => x - ['With,:res] - -asyWrap(record,predlist) == - predlist => ['IF,MKPF(predlist,'AND),record] - record - -asytranCategoryItem(x,levels,predlist,local?) == - x is ['If,predicate,item,:r] => - IFCAR r => error '"ELSE expressions not allowed yet in conditionals" - pred := - predicate is ['Test,r] => r - predicate - asytranCategory(item,levels,[pred,:predlist],local?) - MEMQ(KAR x,'(Default Foreign)) => nil - x is ['Declare,:.] => asytranDeclaration(x,levels,predlist,local?) - x - ---============================================================================ --- Extending Constructor Datatable ---============================================================================ ---FORMAT of $constructorDataTable entry: ---abb kind libFile sourceFile coSig constructorArgs ---alist is ((kind . domain) (libFile . MATRIX) (sourceFile . "matrix") --- (coSig NIL T) (dbLineNumber . 29187) (constructorArgs R) --- (modemap . ( --- (|Matrix| |#1|) --- (Join (MatrixCategory #1 (Vector #1) (Vector #1)) --- (CATEGORY domain --- (SIGNATURE diagonalMatrix ($ (Vector #1))) --- (IF (has #1 (Field)) --- (SIGNATURE inverse ((Union $ "failed") $)) noBranch))) --- (Ring)) --- (T Matrix)) ) -extendConstructorDataTable() == --- tb := $constructorDataTable - for x in listSort(function GLESSEQP,HKEYS $conHash) repeat --- if LASSOC(x,tb) then tb := DELLASOS(x,tb) - record := HGET($conHash,x) - [form,sig,predlist,origin,exposure,comments,typeCode,:filename] := first record - abb := asyAbbreviation(x,#(rest sig)) - kind := 'domain - --Note: this "first" assumes that there is ONLY one sig per name - cosig := [nil,:asyCosig sig] - args := asyConstructorArgs sig - tb := - [[x,abb, - ['kind,:kind], - ['cosig,:cosig], - ['libfile,filename], - ['sourceFile,STRINGIMAGE filename], - ['constructorArgs,:args]],:tb] - listSort(function GLESSEQP,ASSOCLEFT tb) - -asyConstructorArgs sig == - sig is ['With,:.] => nil - sig is ['_-_>,source,target] => - source is [op,:argl] and asyComma? op => [asyConstructorArg x for x in argl] - [asyConstructorArg source] - -asyConstructorArg x == - x is ['Declare,name,t,:.] => name - x - -asyCosig sig == --can be a type or could be a signature - atom sig or sig is ['With,:.] => nil - sig is ['_-_>,source,target] => - source is [op,:argl] and asyComma? op => [asyCosigType x for x in argl] - [asyCosigType source] - error false - -asyCosigType u == - u is [name,t] => - t is [fn,:.] => - asyComma? fn => fn - fn = 'With => 'T - nil - t = 'Type => 'T - error '"Unknown atomic type" - error false - -asyAbbreviation(id,n) == chk(id,main) where --> n = number of arguments - main == - a := createAbbreviation id => a - name := PNAME id --- #name < 8 => INTERN UPCASE name - parts := asySplit(name,MAXINDEX name) - newname := "STRCONC"/[asyShorten x for x in parts] - #newname < 8 => INTERN newname - tryname := SUBSTRING(name,0,7) - not createAbbreviation tryname => INTERN UPCASE tryname - nil - chk(conname,abb) == - (xx := asyGetAbbrevFromComments conname) => xx - con := abbreviation? abb => - conname = con => abb - conname - abb - -asyGetAbbrevFromComments con == - docHash := HGET($docHash,con) - u := [[op,:[fn(x,op) for x in rec]] for op in HKEYS docHash - | rec := HGET(docHash,op)] where fn(x,op) == - [form,sig,pred,origin,where?,comments,:.] := x - ----------> Constants change <-------------- - if IDENTP sig then sig := [sig] - [asySignature(sig,nil),trimComments comments] - [form,sig,pred,origin,where?,comments] := first HGET($conHash,con) - --above "first" assumes only one entry - x := asyExtractAbbreviation comments - x => intern x - NIL - -asyExtractAbbreviation str == - not (k:= STRPOS('"Abbrev: ",str,0,nil)) => NIL - str := SUBSTRING(str, k+8, nil) - k := STRPOS($stringNewline, str,0,nil) - k => SUBSTRING(str, 0, k) - str - -asyShorten x == - y := createAbbreviation x - or LASSOC(x, - '(("Small" . "SM") ("Single" ."S") ("Half" . "H")("Point" . "PT") - ("Floating" . "F") ("System" . "SYS") ("Number" . "N") - ("Inventor" . "IV") - ("Finite" . "F") ("Double" . "D") ("Builtin" . "BI"))) => y - UPCASE x - -asySplit(name,end) == - end < 1 => [name] - k := 0 - for i in 1..end while LOWER_-CASE_-P name.i repeat k := i - k := k + 1 - [SUBSTRING(name,0,k),:asySplit(SUBSTRING(name,k,nil),end-k)] - -createAbbreviation s == - if STRINGP s then s := INTERN s - a := constructor? s - a ^= s => a - nil - ---============================================================================ --- extending getConstructorModemap Property ---============================================================================ ---Note: modemap property is built when getConstructorModemap is called - -asyConstructorModemap con == - HGET($conHash,con) isnt [record,:.] => nil --not there - [form,sig,predlist,kind,exposure,comments,typeCode,:filename] := record - $kind: local := kind - --NOTE: sig has the form (-> source target) or simply (target) - $constructorArgs: local := KDR form - signature := asySignature(sig,false) - formals := ['_$,:TAKE(#$constructorArgs,$FormalMapVariableList)] - mm := [[[con,:$constructorArgs],:signature],['T,con]] - SUBLISLIS(formals,['_%,:$constructorArgs],mm) - -asySignature(sig,names?) == - sig is ['Join,:.] => [asySig(sig,nil)] - sig is ['With,:.] => [asySig(sig,nil)] - sig is ['_-_>,source,target] => - target := - names? => ['dummy,target] - target - source is [op,:argl] and asyComma? op => - [asySigTarget(target,names?),:[asySig(x,names?) for x in argl]] - [asySigTarget(target,names?),asySig(source,names?)] - ----------> The following is a hack for constants which are category names<-- - sig is ['Third,:.] => [asySig(sig,nil)] - ----------> Constants change <-------------- - asySig(sig,nil) - -asySigTarget(u,name?) == asySig1(u,name?,true) - -asySig(u,name?) == asySig1(u,name?,false) - -asySig1(u,name?,target?) == - x := - name? and u is [name,t] => t - u - x is [fn,:r] => - fn = 'Join => asyTypeJoin r ---------> jump out to newer code 4/94 - MEMQ(fn, '(RestrictTo PretendTo)) => asySig(first r,name?) - asyComma? fn => - u := [asySig(x,name?) for x in r] - target? => - null u => '(Void) - -- this implies a multiple value return, not currently supported - -- in the interpreter - ['Multi,:u] - u - fn = 'With => asyCATEGORY r - fn = 'Third => - r is [b] => - b is ['With,:s] => asyCATEGORY s - b is ['Blank,:.] => asyCATEGORY nil - error x - fn = 'Apply and r is ['_-_>,:s] => asyMapping(s,name?) - fn = '_-_> => asyMapping(r,name?) - fn = 'Declare and r is [name,typ,:.] => - asySig1(typ, name?, target?) - x is '(_%) => '(_$) - [fn,:[asySig(x,name?) for x in r]] ---x = 'Type => '(Type) - x = '_% => '_$ - x - --- old version was : ---asyMapping([a,b],name?) == --- a := asySig(a,name?) --- b := asySig(b,name?) --- args := --- a is [op,:r] and asyComma? op => r --- [a] --- ['Mapping,b,:args] - -asyMapping([a,b],name?) == - newa := asySig(a,name?) - b := asySig(b,name?) - args := - a is [op,:r] and asyComma? op => newa - [a] - ['Mapping,b,:args] - ---============================================================================ --- code for asySignatures of the form (Join,:...) ---============================================================================ -asyType x == - x is [fn,:r] => - fn = 'Join => asyTypeJoin r - MEMQ(fn, '(RestrictTo PretendTo)) => asyType first r - asyComma? fn => - u := [asyType x for x in r] - u - fn = 'With => asyCATEGORY r - fn = '_-_> => asyTypeMapping r - fn = 'Apply => r --- fn = 'Declare and r is [name,typ,:.] => typ - x is '(_%) => '(_$) - x ---x = 'Type => '(Type) - x = '_% => '_$ - x - -asyTypeJoin r == - $conStack : local := nil - $opStack : local := nil - $predlist : local := nil - for x in r repeat asyTypeJoinPart(x,$predlist) - catpart := - $opStack => ['CATEGORY,$kind,:asyTypeJoinStack REVERSE $opStack] - nil - conpart := asyTypeJoinStack REVERSE $conStack - conpart => - catpart => ['Join,:conpart,catpart] - CDR conpart => ['Join,:conpart] - conpart - catpart - -asyTypeJoinPart(x,$predlist) == - x is ['Join,:y] => for z in y repeat asyTypeJoinPart(z, $predlist) - x is ['With,:y] => for p in y repeat asyTypeJoinPartWith p - asyTypeJoinPartWith x - -asyTypeJoinPartWith x == - x is ['Exports,:y] => for p in y repeat asyTypeJoinPartExport p - x is ['Exports,:.] => systemError 'exports - x is ['Comma] => nil - x is ['Export,:y] => nil - x is ['IF,:r] => asyTypeJoinPartIf r - x is ['Sequence,:x] => for y in x repeat asyTypeJoinItem y - asyTypeJoinItem x - -asyTypeJoinPartIf [pred,value] == - predlist := [asyTypeJoinPartPred pred,:$predlist] - asyTypeJoinPart(value,predlist) - -asyTypeJoinPartPred x == - x is ['Test, y] => asyTypeUnit y - asyTypeUnit x - -asyTypeJoinItem x == - result := asyTypeUnit x - isLowerCaseLetter (PNAME opOf result).0 => - $opStack := [[['ATTRIBUTE,result],:$predlist],:$opStack] - $conStack := [[result,:$predlist],:$conStack] - -asyTypeMapping([a,b]) == - a := asyTypeUnit a - b := asyTypeUnit b - args := - a is [op,:r] and asyComma? op => r - [a] - ['Mapping,b,:args] - -asyTypeUnit x == - x is [fn,:r] => - fn = 'Join => systemError 'Join ----->asyTypeJoin r - MEMQ(fn, '(RestrictTo PretendTo)) => asyTypeUnit first r - asyComma? fn => - u := [asyTypeUnit x for x in r] - u - fn = 'With => asyCATEGORY r - fn = '_-_> => asyTypeMapping r - fn = 'Apply => asyTypeUnitList r - fn = 'Declare and r is [name,typ,:.] => asyTypeUnitDeclare(name,typ) - x is '(_%) => '(_$) - [fn,:asyTypeUnitList r] - GET(x,'NILADIC) => [x] ---x = 'Type => '(Type) - x = '_% => '_$ - x - -asyTypeUnitList x == [asyTypeUnit y for y in x] - -asyTypeUnitDeclare(op,typ) == - typ is ['Apply, :r] => asyCatSignature(op,r) - asyTypeUnit typ ---============================================================================ --- Translator for ['With,:.] ---============================================================================ -asyCATEGORY x == - if x is [join,:y] and join is ['Apply,:s] then - exports := y - joins := - s is ['Join,:r] => [asyJoinPart u for u in r] - [asyJoinPart s] - else if x is [id,:y] and IDENTP id then - joins := [[id]] - exports := y - else - joins := nil - exports := x - cats := exports - operations := nil - if exports is [:r,['Exports,:ops]] then - cats := r - operations := ops - exportPart := - ['CATEGORY,'domain,:"APPEND"/[asyCatItem y for y in operations]] - [attribs, na] := asyFindAttrs joins - joins := na - cats := "append"/[asyCattran c for c in cats] - [a, na] := asyFindAttrs cats - cats := na - attribs := APPEND(attribs, a) - attribs := [['ATTRIBUTE, x] for x in attribs] - exportPart := [:exportPart,:attribs] - joins or cats or attribs => - ['Join,:joins,:cats, exportPart] - exportPart - -asyFindAttrs l == - attrs := [] - notattrs := [] - for x in l repeat - x0 := x - while CONSP x repeat x := CAR x - if MEMQ(x, _*ATTRIBUTES_*) then attrs := [:attrs, x] - else notattrs := [:notattrs, x0] - [attrs, notattrs] - -simpCattran x == - u := asyCattran x - u is [y] => y - ['Join,:u] - -asyCattran x == - x is ['With,:r] => "append"/[asyCattran1 x for x in r] - x is ['IF,:.] => "append"/[asyCattranConstructors(x,nil)] - [x] - -asyCattran1 x == - x is ['Exports,:y] => "append"/[asyCattranOp u for u in y] - x is ['IF,:.] => "append"/[asyCattranConstructors(x,nil)] - systemError nil - -asyCattranOp [op,:items] == - "append"/[asyCattranOp1(op,item,nil) for item in items] - -asyCattranOp1(op, item, predlist) == - item is ['IF, p, x] => - pred := asyPredTran - p is ['Test,t] => t - p --- x is ['IF,:.] => "append"/[asyCattranOp1('IF, x, [pred,:predlist])] --- This line used to call asyCattranOp1 with too few arguments. Following --- fix suggested by RDJ. - x is ['IF,:.] => "append"/[asyCattranOp1(op,y,[pred,:predlist]) for y in x] - [['IF, asySimpPred(pred,predlist), asyCattranSig(op,x), 'noBranch]] - [asyCattranSig(op,item)] - -asyPredTran p == asyPredTran1 asyJoinPart p - -asyPredTran1 p == - p is ['Has,x,y] => ['has,x, simpCattran y] - p is ['Test, q] => asyPredTran1 q - p is [op,:r] and MEMQ(op,'(AND OR NOT)) => - [op,:[asyPredTran1 q for q in r]] - p - -asyCattranConstructors(item, predlist) == - item is ['IF, p, x] => - pred := asyPredTran - p is ['Test,t] => t - p - x is ['IF,:.] => "append"/[asyCattranConstructors(x, [pred,:predlist])] - form := ['ATTRIBUTE, asyJoinPart x] - [['IF, asySimpPred(pred,predlist), form, 'noBranch]] - systemError() - -asySimpPred(p, predlist) == - while predlist is [q,:predlist] repeat p := quickAnd(q,p) - p - -asyCattranSig(op,y) == - y isnt ["->",source,t] => --- ['SIGNATURE, op, asyTypeUnit y] --- following makes constants into nullary functions - ['SIGNATURE, op, [asyTypeUnit y]] - s := - source is ['Comma,:s] => [asyTypeUnit z for z in s] - [asyTypeUnit source] - t := asyTypeUnit t - null t => ['SIGNATURE,op,s] - ['SIGNATURE,op,[t,:s]] - -asyJoinPart x == - IDENTP x => [x] - asytranForm(x,nil,true) - -asyCatItem item == - atom item => [item] - item is ['IF,.,.] => [item] - [op,:sigs] := item - [asyCatSignature(op,sig) for sig in sigs | sig] - -asyCatSignature(op,sig) == - sig is ['_-_>,source,target] => - ['SIGNATURE,op, [asyTypeItem target,:asyUnTuple source]] - ----------> Constants change <-------------- --- ['TYPE,op,asyTypeItem sig] --- following line converts constants into nullary functions - ['SIGNATURE,op,[asyTypeItem sig]] - -asyUnTuple x == - x is [op,:u] and asyComma? op => [asyTypeItem y for y in u] - [asyTypeItem x] - -asyTypeItem x == - atom x => - x = '_% => '_$ - x - x is ['_-_>,a,b] => - ['Mapping,b,:asyUnTuple a] - x is ['Apply,:r] => - r is ['_-_>,a,b] => - ['Mapping,b,:asyUnTuple a] - r is ['Record,:parts] => - ['Record,:[[":",a,b] for ['Declare,a,b,:.] in parts]] - r is ['Segment,:parts] => - ['Segment,:[asyTypeItem x for x in parts]] - asytranApply(x,nil,true) - x is ['Declare,.,t,:.] => asyTypeItem t - x is ['Comma,:args] => - -- this implies a multiple value return, not currently supported - -- in the interpreter - args => ['Multi,:[asyTypeItem y for y in args]] - ['Void] - [asyTypeItem y for y in x] - ---============================================================================ --- Utilities ---============================================================================ -asyComma? op == MEMQ(op,'(Comma Multi)) - - -hput(table,name,value) == - if null name then systemError() - HPUT(table,name,value) - ---============================================================================ --- category parts ---============================================================================ - --- this constructs operation information from a category. --- NB: This is categoryParts, but with the kind supplied by --- an arguments -asCategoryParts(kind,conform,category,:options) == main where - main == - cons? := IFCAR options --means to include constructors as well - $attrlist: local := nil - $oplist : local := nil - $conslist: local := nil - conname := opOf conform - for x in exportsOf(category) repeat build(x,true) - $attrlist := listSort(function GLESSEQP,$attrlist) - $oplist := listSort(function GLESSEQP,$oplist) - res := [$attrlist,:$oplist] - if cons? then res := [listSort(function GLESSEQP,$conslist),:res] - if kind = 'category then - tvl := TAKE(#rest conform,$TriangleVariableList) - res := SUBLISLIS($FormalMapVariableList,tvl,res) - res - build(item,pred) == - item is ['SIGNATURE,op,sig,:.] => $oplist := [[opOf op,sig,:pred],:$oplist] - --note: opOf is needed!!! Bug in compiler puts in (One) and (Zero) - item is ['ATTRIBUTE,attr] => - constructor? opOf attr => - $conslist := [[attr,:pred],:$conslist] - nil - opOf attr = 'nothing => 'skip - $attrlist := [[opOf attr,IFCDR attr,:pred],:$attrlist] - item is ['TYPE,op,type] => - $oplist := [[op,[type],:pred],:$oplist] - item is ['IF,pred1,s1,s2] => - build(s1,quickAnd(pred,pred1)) - s2 => build(s2,quickAnd(pred,['NOT,pred1])) - item is ['PROGN,:r] => for x in r repeat build(x,pred) - item in '(noBranch) => 'ok - null item => 'ok - systemError '"build error" - exportsOf(target) == - target is ['CATEGORY,.,:r] => r - target is ['Join,:r,f] => - for x in r repeat $conslist := [[x,:true],:$conslist] - exportsOf f - $conslist := [[target,:true],:$conslist] - nil - ---============================================================================ --- Dead Code (for a very odd value of 'dead') ---============================================================================ -asyTypeJoinPartExport x == - [op,:items] := x - for y in items repeat - y isnt ["->",source,t] => --- sig := ['TYPE, op, asyTypeUnit y] --- converts constants to nullary functions (this code isn't dead) - sig := ['SIGNATURE, op, [asyTypeUnit y]] - $opStack := [[sig,:$predlist],:$opStack] - s := - source is ['Comma,:s] => [asyTypeUnit z for z in s] - [asyTypeUnit source] - t := asyTypeUnit t - sig := - null t => ['SIGNATURE,op,s] - ['SIGNATURE,op,[t,:s]] - $opStack := [[sig,:$predlist],:$opStack] - ---============================================================================ --- Code to create opDead Code ---============================================================================ -asyTypeJoinStack r == - al := [[[x while r is [[x, :q],:s] and p = q and (r := s; true)],:p] - while r is [[.,:p],:.]] - result := "append"/[fn for [y,:p] in al] where fn == - p => [['IF,asyTypeMakePred p,:y]] - y - result - -asyTypeMakePred [p,:u] == - while u is [q,:u] repeat p := quickAnd(q,p) - p - - - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/as.lisp.pamphlet b/src/interp/as.lisp.pamphlet new file mode 100644 index 0000000..3432d5f --- /dev/null +++ b/src/interp/as.lisp.pamphlet @@ -0,0 +1,4811 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp as.lisp} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +<<*>>= +(IN-PACKAGE "BOOT" ) + +;--global hash tables for new compiler +;$docHash := MAKE_-HASH_-TABLE() + +(SPADLET |$docHash| (MAKE-HASH-TABLE)) + +;$conHash := MAKE_-HASH_-TABLE() + +(SPADLET |$conHash| (MAKE-HASH-TABLE)) + +;$opHash := MAKE_-HASH_-TABLE() + +(SPADLET |$opHash| (MAKE-HASH-TABLE)) + +;$asyPrint := false + +(SPADLET |$asyPrint| NIL) + +;asList() == +; OBEY '"rm -f temp.text" +; OBEY '"ls as/*.asy > temp.text" +; instream := OPEN '"temp.text" +; lines := [READLINE instream while not EOFP instream] +; CLOSE instream +; lines + +(DEFUN |asList| () + (PROG (|instream| |lines|) + (RETURN + (SEQ (PROGN + (OBEY (MAKESTRING "rm -f temp.text")) + (OBEY (MAKESTRING "ls as/*.asy > temp.text")) + (SPADLET |instream| (OPEN (MAKESTRING "temp.text"))) + (SPADLET |lines| + (PROG (G166062) + (SPADLET G166062 NIL) + (RETURN + (DO () + ((NULL (NULL (EOFP |instream|))) + (NREVERSE0 G166062)) + (SEQ (EXIT (SETQ G166062 + (CONS (READLINE |instream|) + G166062)))))))) + (CLOSE |instream|) + |lines|))))) + +;asAll lines == +; for x in lines repeat +; sayBrightly ['"-----> ",x] +; asTran x +; 'done + +(DEFUN |asAll| (|lines|) + (SEQ (PROGN + (DO ((G166083 |lines| (CDR G166083)) (|x| NIL)) + ((OR (ATOM G166083) + (PROGN (SETQ |x| (CAR G166083)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (|sayBrightly| + (CONS (MAKESTRING "-----> ") + (CONS |x| NIL))) + (|asTran| |x|))))) + '|done|))) + +;as name == +; astran STRCONC(STRINGIMAGE name,'".asy") +;-- astran STRCONC(getEnv('"AXIOM"), +;-- '"/../../obj/rios/as/",STRINGIMAGE name,'".asy") +; 'done + +(DEFUN |as| (|name|) + (PROGN + (|astran| (STRCONC (STRINGIMAGE |name|) (MAKESTRING ".asy"))) + '|done|)) + +;astran asyFile == +;--global hash tables for new compiler +; $docHash := MAKE_-HASH_-TABLE() +; $conHash := MAKE_-HASH_-TABLE() +; $constantHash := MAKE_-HASH_-TABLE() +; $niladics : local := nil +; $asyFile: local := asyFile +; $asFilename: local := STRCONC(PATHNAME_-NAME asyFile,'".as") +; asytran asyFile +; conlist := [x for x in HKEYS $conHash | HGET($conHash,x) isnt [.,.,"function",:.]] +; $mmAlist : local := +; [[con,:asyConstructorModemap con] for con in conlist] +; $docAlist : local := +; [[con,:REMDUP asyDocumentation con] for con in conlist] +; $parentsHash : local := MAKE_-HASH_-TABLE() +;--$childrenHash: local := MAKE_-HASH_-TABLE() +; for con in conlist repeat +; parents := asyParents con +; HPUT($parentsHash,con,asyParents con) +;-- for [parent,:pred] in parents repeat +;-- parentOp := opOf parent +;-- HPUT($childrenHash,parentOp,insert([con,:pred],HGET($childrenHash,parentOp))) +; $newConlist := UNION(conlist, $newConlist) +; [[x,:asMakeAlist x] for x in HKEYS $conHash] + +(DEFUN |astran| (|asyFile|) + (PROG (|$niladics| |$asyFile| |$asFilename| |$mmAlist| |$docAlist| + |$parentsHash| |ISTMP#1| |ISTMP#2| |ISTMP#3| |conlist| + |parents|) + (DECLARE (SPECIAL |$niladics| |$asyFile| |$asFilename| |$mmAlist| + |$docAlist| |$parentsHash| |$conHash| |$newConlist| + |$constantHash| |$docHash|)) + (RETURN + (SEQ (PROGN + (SPADLET |$docHash| (MAKE-HASH-TABLE)) + (SPADLET |$conHash| (MAKE-HASH-TABLE)) + (SPADLET |$constantHash| (MAKE-HASH-TABLE)) + (SPADLET |$niladics| NIL) + (SPADLET |$asyFile| |asyFile|) + (SPADLET |$asFilename| + (STRCONC (PATHNAME-NAME |asyFile|) + (MAKESTRING ".as"))) + (|asytran| |asyFile|) + (SPADLET |conlist| + (PROG (G166115) + (SPADLET G166115 NIL) + (RETURN + (DO ((G166121 (HKEYS |$conHash|) + (CDR G166121)) + (|x| NIL)) + ((OR (ATOM G166121) + (PROGN + (SETQ |x| (CAR G166121)) + NIL)) + (NREVERSE0 G166115)) + (SEQ (EXIT (COND + ((NULL + (PROGN + (SPADLET |ISTMP#1| + (HGET |$conHash| |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND + (PAIRP |ISTMP#3|) + (EQ + (QCAR |ISTMP#3|) + '|function|)))))))) + (SETQ G166115 + (CONS |x| G166115)))))))))) + (SPADLET |$mmAlist| + (PROG (G166131) + (SPADLET G166131 NIL) + (RETURN + (DO ((G166136 |conlist| (CDR G166136)) + (|con| NIL)) + ((OR (ATOM G166136) + (PROGN + (SETQ |con| (CAR G166136)) + NIL)) + (NREVERSE0 G166131)) + (SEQ (EXIT (SETQ G166131 + (CONS + (CONS |con| + (|asyConstructorModemap| + |con|)) + G166131)))))))) + (SPADLET |$docAlist| + (PROG (G166146) + (SPADLET G166146 NIL) + (RETURN + (DO ((G166151 |conlist| (CDR G166151)) + (|con| NIL)) + ((OR (ATOM G166151) + (PROGN + (SETQ |con| (CAR G166151)) + NIL)) + (NREVERSE0 G166146)) + (SEQ (EXIT (SETQ G166146 + (CONS + (CONS |con| + (REMDUP + (|asyDocumentation| |con|))) + G166146)))))))) + (SPADLET |$parentsHash| (MAKE-HASH-TABLE)) + (DO ((G166162 |conlist| (CDR G166162)) (|con| NIL)) + ((OR (ATOM G166162) + (PROGN (SETQ |con| (CAR G166162)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |parents| (|asyParents| |con|)) + (HPUT |$parentsHash| |con| + (|asyParents| |con|)))))) + (SPADLET |$newConlist| (|union| |conlist| |$newConlist|)) + (PROG (G166172) + (SPADLET G166172 NIL) + (RETURN + (DO ((G166177 (HKEYS |$conHash|) (CDR G166177)) + (|x| NIL)) + ((OR (ATOM G166177) + (PROGN (SETQ |x| (CAR G166177)) NIL)) + (NREVERSE0 G166172)) + (SEQ (EXIT (SETQ G166172 + (CONS + (CONS |x| (|asMakeAlist| |x|)) + G166172)))))))))))) + +;asyParents(conform) == +; acc := nil +; con:= opOf conform +;--formals := TAKE(#formalParams,$TriangleVariableList) +; modemap := LASSOC(con,$mmAlist) +; $constructorCategory :local := asySubstMapping CADAR modemap +; for x in folks $constructorCategory repeat +;-- x := SUBLISLIS(formalParams,formals,x) +;-- x := SUBLISLIS(IFCDR conform,formalParams,x) +;-- x := SUBST('Type,'Object,x) +; acc := [:explodeIfs x,:acc] +; NREVERSE acc + +(DEFUN |asyParents| (|conform|) + (PROG (|$constructorCategory| |con| |modemap| |acc|) + (DECLARE (SPECIAL |$constructorCategory| |$mmAlist|)) + (RETURN + (SEQ (PROGN + (SPADLET |acc| NIL) + (SPADLET |con| (|opOf| |conform|)) + (SPADLET |modemap| (LASSOC |con| |$mmAlist|)) + (SPADLET |$constructorCategory| + (|asySubstMapping| (CADAR |modemap|))) + (DO ((G166221 (|folks| |$constructorCategory|) + (CDR G166221)) + (|x| NIL)) + ((OR (ATOM G166221) + (PROGN (SETQ |x| (CAR G166221)) NIL)) + NIL) + (SEQ (EXIT (SPADLET |acc| + (APPEND (|explodeIfs| |x|) |acc|))))) + (NREVERSE |acc|)))))) + +;asySubstMapping u == +; u is [op,:r] => +; op = "->" => +; [s, t] := r +; args := +; s is [op,:u] and asyComma? op => [asySubstMapping y for y in u] +; [asySubstMapping s] +; ['Mapping, asySubstMapping t, :args] +; [asySubstMapping x for x in u] +; u + +(DEFUN |asySubstMapping| (|u|) + (PROG (|r| |s| |t| |op| |args|) + (RETURN + (SEQ (COND + ((AND (PAIRP |u|) + (PROGN + (SPADLET |op| (QCAR |u|)) + (SPADLET |r| (QCDR |u|)) + 'T)) + (COND + ((BOOT-EQUAL |op| '->) (SPADLET |s| (CAR |r|)) + (SPADLET |t| (CADR |r|)) + (SPADLET |args| + (COND + ((AND (PAIRP |s|) + (PROGN + (SPADLET |op| (QCAR |s|)) + (SPADLET |u| (QCDR |s|)) + 'T) + (|asyComma?| |op|)) + (PROG (G166254) + (SPADLET G166254 NIL) + (RETURN + (DO ((G166259 |u| (CDR G166259)) + (|y| NIL)) + ((OR (ATOM G166259) + (PROGN + (SETQ |y| (CAR G166259)) + NIL)) + (NREVERSE0 G166254)) + (SEQ + (EXIT + (SETQ G166254 + (CONS (|asySubstMapping| |y|) + G166254)))))))) + ('T (CONS (|asySubstMapping| |s|) NIL)))) + (CONS '|Mapping| + (CONS (|asySubstMapping| |t|) |args|))) + ('T + (PROG (G166269) + (SPADLET G166269 NIL) + (RETURN + (DO ((G166274 |u| (CDR G166274)) (|x| NIL)) + ((OR (ATOM G166274) + (PROGN (SETQ |x| (CAR G166274)) NIL)) + (NREVERSE0 G166269)) + (SEQ (EXIT (SETQ G166269 + (CONS (|asySubstMapping| |x|) + G166269)))))))))) + ('T |u|)))))) + +;--asyFilePackage asyFile == +;-- name := INTERN PATHNAME_-NAME asyFile +;-- modemap := +;-- [[[name],['CATEGORY,'domain, +;-- :[asyMkSignature(con,CDAR mm) for [con,:mm] in $mmAlist]]],['T,name]] +;-- opAlist := [[con,[CDAR mm]] for [con,:mm] in $mmAlist] +;-- documentation := +;-- [[con,[CDAR mm,fn LASSOC(con,$docAlist)]] for [con,:mm] in $mmAlist] +;-- where fn u == +;-- LASSOC('constructor,u) is [[=nil,doc]] => doc +;-- '"" +;-- res := [['constructorForm,name],['constant,:'true], +;-- ['constructorKind,:'file], +;-- ['constructorModemap,:modemap], +;-- ['sourceFile,:PNAME name], +;-- ['operationAlist,:zeroOneConversion opAlist], +;-- ['documentation,:documentation]] +;--asyDisplay(name,res) +;-- [name,:res] +;asyMkSignature(con,sig) == +;-- atom sig => ['TYPE,con,sig] +;-- following line converts constants into nullary functions +; atom sig => ['SIGNATURE,con,[sig]] +; ['SIGNATURE,con,sig] + +(DEFUN |asyMkSignature| (|con| |sig|) + (COND + ((ATOM |sig|) + (CONS 'SIGNATURE (CONS |con| (CONS (CONS |sig| NIL) NIL)))) + ('T (CONS 'SIGNATURE (CONS |con| (CONS |sig| NIL)))))) + +;asMakeAlist con == +; record := HGET($conHash,con) +; [form,sig,predlist,kind,exposure,comments,typeCode,:filename] := first record +;--TTT in case we put the wrong thing in for niladic catgrs +;--if ATOM(form) and kind='category then form:=[form] +; if ATOM(form) then form:=[form] +; kind = 'function => asMakeAlistForFunction con +; abb := asyAbbreviation(con,#(KDR sig)) +; if null KDR form then PUT(opOf form,'NILADIC,'T) +; modemap := asySubstMapping LASSOC(con,$mmAlist) +; $constructorCategory :local := CADAR modemap +; parents := mySort HGET($parentsHash,con) +;--children:= mySort HGET($childrenHash,con) +; alists := HGET($opHash,con) +; opAlist := SUBLISLIS($FormalMapVariableList,KDR form,CDDR alists) +; ancestorAlist:= SUBLISLIS($FormalMapVariableList,KDR form,CAR alists) +; catAttrs := [[x,:true] for x in getAttributesFromCATEGORY $constructorCategory] +; attributeAlist := REMDUP [:CADR alists,:catAttrs] +; documentation := +; SUBLISLIS($FormalMapVariableList,KDR form,LASSOC(con,$docAlist)) +; filestring := STRCONC(PATHNAME_-NAME STRINGIMAGE filename,'".as") +; constantPart := HGET($constantHash,con) and [['constant,:true]] +; niladicPart := MEMQ(con,$niladics) and [['NILADIC,:true]] +; falist := TAKE(#KDR form,$FormalMapVariableList) +; constructorCategory := +; kind = 'category => +; talist := TAKE(#KDR form, $TriangleVariableList) +; SUBLISLIS(talist, falist, $constructorCategory) +; SUBLISLIS(falist,KDR form,$constructorCategory) +; if constructorCategory='Category then kind := 'category +; exportAlist := asGetExports(kind, form, constructorCategory) +; constructorModemap := SUBLISLIS(falist,KDR form,modemap) +;--TTT fix a niladic category constructormodemap (remove the joins) +; if kind = 'category then +; SETF(CADAR(constructorModemap),['Category]) +; res := [['constructorForm,:form],:constantPart,:niladicPart, +; ['constructorKind,:kind], +; ['constructorModemap,:constructorModemap], +; ['abbreviation,:abb], +; ['constructorCategory,:constructorCategory], +; ['parents,:parents], +; ['attributes,:attributeAlist], +; ['ancestors,:ancestorAlist], +; -- ['children,:children], +; ['sourceFile,:filestring], +; ['operationAlist,:zeroOneConversion opAlist], +; ['modemaps,:asGetModemaps(exportAlist,form,kind,modemap)], +; ['sourcefile,:$asFilename], +; ['typeCode,:typeCode], +; ['documentation,:documentation]] +; if $asyPrint then asyDisplay(con,res) +; res + +(DEFUN |asMakeAlist| (|con|) + (PROG (|$constructorCategory| |record| |LETTMP#1| |sig| |predlist| + |exposure| |comments| |typeCode| |filename| |form| |abb| + |modemap| |parents| |alists| |opAlist| |ancestorAlist| + |catAttrs| |attributeAlist| |documentation| |filestring| + |constantPart| |niladicPart| |falist| |talist| + |constructorCategory| |kind| |exportAlist| + |constructorModemap| |res|) + (DECLARE (SPECIAL |$constructorCategory| |$asyPrint| |$asFilename| + |$TriangleVariableList| |$FormalMapVariableList| + |$niladics| |$constantHash| |$docAlist| |$opHash| + |$parentsHash| |$mmAlist| |$conHash|)) + (RETURN + (SEQ (PROGN + (SPADLET |record| (HGET |$conHash| |con|)) + (SPADLET |LETTMP#1| (CAR |record|)) + (SPADLET |form| (CAR |LETTMP#1|)) + (SPADLET |sig| (CADR |LETTMP#1|)) + (SPADLET |predlist| (CADDR |LETTMP#1|)) + (SPADLET |kind| (CADDDR |LETTMP#1|)) + (SPADLET |exposure| (CAR (CDDDDR |LETTMP#1|))) + (SPADLET |comments| (CADR (CDDDDR |LETTMP#1|))) + (SPADLET |typeCode| (CADDR (CDDDDR |LETTMP#1|))) + (SPADLET |filename| (CDDDR (CDDDDR |LETTMP#1|))) + (COND ((ATOM |form|) (SPADLET |form| (CONS |form| NIL)))) + (COND + ((BOOT-EQUAL |kind| '|function|) + (|asMakeAlistForFunction| |con|)) + ('T + (SPADLET |abb| + (|asyAbbreviation| |con| (|#| (KDR |sig|)))) + (COND + ((NULL (KDR |form|)) + (PUT (|opOf| |form|) 'NILADIC 'T))) + (SPADLET |modemap| + (|asySubstMapping| (LASSOC |con| |$mmAlist|))) + (SPADLET |$constructorCategory| (CADAR |modemap|)) + (SPADLET |parents| + (|mySort| (HGET |$parentsHash| |con|))) + (SPADLET |alists| (HGET |$opHash| |con|)) + (SPADLET |opAlist| + (SUBLISLIS |$FormalMapVariableList| + (KDR |form|) (CDDR |alists|))) + (SPADLET |ancestorAlist| + (SUBLISLIS |$FormalMapVariableList| + (KDR |form|) (CAR |alists|))) + (SPADLET |catAttrs| + (PROG (G166322) + (SPADLET G166322 NIL) + (RETURN + (DO ((G166327 + (|getAttributesFromCATEGORY| + |$constructorCategory|) + (CDR G166327)) + (|x| NIL)) + ((OR (ATOM G166327) + (PROGN + (SETQ |x| (CAR G166327)) + NIL)) + (NREVERSE0 G166322)) + (SEQ (EXIT + (SETQ G166322 + (CONS (CONS |x| 'T) G166322)))))))) + (SPADLET |attributeAlist| + (REMDUP (APPEND (CADR |alists|) |catAttrs|))) + (SPADLET |documentation| + (SUBLISLIS |$FormalMapVariableList| + (KDR |form|) (LASSOC |con| |$docAlist|))) + (SPADLET |filestring| + (STRCONC (PATHNAME-NAME + (STRINGIMAGE |filename|)) + (MAKESTRING ".as"))) + (SPADLET |constantPart| + (AND (HGET |$constantHash| |con|) + (CONS (CONS '|constant| 'T) NIL))) + (SPADLET |niladicPart| + (AND (MEMQ |con| |$niladics|) + (CONS (CONS 'NILADIC 'T) NIL))) + (SPADLET |falist| + (TAKE (|#| (KDR |form|)) + |$FormalMapVariableList|)) + (SPADLET |constructorCategory| + (COND + ((BOOT-EQUAL |kind| '|category|) + (SPADLET |talist| + (TAKE (|#| (KDR |form|)) + |$TriangleVariableList|)) + (SUBLISLIS |talist| |falist| + |$constructorCategory|)) + ('T + (SUBLISLIS |falist| (KDR |form|) + |$constructorCategory|)))) + (COND + ((BOOT-EQUAL |constructorCategory| '|Category|) + (SPADLET |kind| '|category|))) + (SPADLET |exportAlist| + (|asGetExports| |kind| |form| + |constructorCategory|)) + (SPADLET |constructorModemap| + (SUBLISLIS |falist| (KDR |form|) |modemap|)) + (COND + ((BOOT-EQUAL |kind| '|category|) + (SETF (CADAR |constructorModemap|) + (CONS '|Category| NIL)))) + (SPADLET |res| + (CONS (CONS '|constructorForm| |form|) + (APPEND |constantPart| + (APPEND |niladicPart| + (CONS + (CONS '|constructorKind| + |kind|) + (CONS + (CONS '|constructorModemap| + |constructorModemap|) + (CONS + (CONS '|abbreviation| |abb|) + (CONS + (CONS + '|constructorCategory| + |constructorCategory|) + (CONS + (CONS '|parents| + |parents|) + (CONS + (CONS '|attributes| + |attributeAlist|) + (CONS + (CONS '|ancestors| + |ancestorAlist|) + (CONS + (CONS '|sourceFile| + |filestring|) + (CONS + (CONS + '|operationAlist| + (|zeroOneConversion| + |opAlist|)) + (CONS + (CONS '|modemaps| + (|asGetModemaps| + |exportAlist| + |form| |kind| + |modemap|)) + (CONS + (CONS '|sourcefile| + |$asFilename|) + (CONS + (CONS '|typeCode| + |typeCode|) + (CONS + (CONS + '|documentation| + |documentation|) + NIL))))))))))))))))) + (COND (|$asyPrint| (|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] + +(DEFUN |asGetExports| (|kind| |conform| |catform|) + (PROG (|u| |op| |sig| |pred|) + (RETURN + (SEQ (PROGN + (SPADLET |u| + (OR (|asCategoryParts| |kind| |conform| |catform| + 'T) + (RETURN NIL))) + (PROG (G166390) + (SPADLET G166390 NIL) + (RETURN + (DO ((G166398 (CDDR |u|) (CDR G166398)) + (G166372 NIL)) + ((OR (ATOM G166398) + (PROGN (SETQ G166372 (CAR G166398)) NIL) + (PROGN + (PROGN + (SPADLET |op| (CAR G166372)) + (SPADLET |sig| (CADR G166372)) + (SPADLET |pred| (CDDR G166372)) + G166372) + NIL)) + (NREVERSE0 G166390)) + (SEQ (EXIT (SETQ G166390 + (CONS + (CONS |op| + (CONS + (PROGN + (SPADLET |pred| + (COND + ((BOOT-EQUAL |pred| 'T) + NIL) + ('T |pred|))) + (CONS |sig| (CONS NIL |pred|))) + NIL)) + G166390)))))))))))) + +;asMakeAlistForFunction fn == +; record := HGET($conHash,fn) +; [form,sig,predlist,kind,exposure,comments,typeCode,:filename] := first record +; modemap := LASSOC(fn,$mmAlist) +; newsig := asySignature(sig,nil) +; opAlist := [[fn,[newsig,nil,:predlist]]] +; res := [['modemaps,:asGetModemaps(opAlist,fn,'function,modemap)], +; ['typeCode,:typeCode]] +; if $asyPrint then asyDisplay(fn,res) +; res + +(DEFUN |asMakeAlistForFunction| (|fn|) + (PROG (|record| |LETTMP#1| |form| |sig| |predlist| |kind| |exposure| + |comments| |typeCode| |filename| |modemap| |newsig| + |opAlist| |res|) + (declare (special |$asyPrint| |$mmAlist| |$conHash|)) + (RETURN + (PROGN + (SPADLET |record| (HGET |$conHash| |fn|)) + (SPADLET |LETTMP#1| (CAR |record|)) + (SPADLET |form| (CAR |LETTMP#1|)) + (SPADLET |sig| (CADR |LETTMP#1|)) + (SPADLET |predlist| (CADDR |LETTMP#1|)) + (SPADLET |kind| (CADDDR |LETTMP#1|)) + (SPADLET |exposure| (CAR (CDDDDR |LETTMP#1|))) + (SPADLET |comments| (CADR (CDDDDR |LETTMP#1|))) + (SPADLET |typeCode| (CADDR (CDDDDR |LETTMP#1|))) + (SPADLET |filename| (CDDDR (CDDDDR |LETTMP#1|))) + (SPADLET |modemap| (LASSOC |fn| |$mmAlist|)) + (SPADLET |newsig| (|asySignature| |sig| NIL)) + (SPADLET |opAlist| + (CONS (CONS |fn| + (CONS (CONS |newsig| + (CONS NIL |predlist|)) + NIL)) + NIL)) + (SPADLET |res| + (CONS (CONS '|modemaps| + (|asGetModemaps| |opAlist| |fn| + '|function| |modemap|)) + (CONS (CONS '|typeCode| |typeCode|) NIL))) + (COND (|$asyPrint| (|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 + +(DEFUN |getAttributesFromCATEGORY| (|catform|) + (PROG (|r| |y| |ISTMP#1| |ISTMP#2| |x| |m|) + (RETURN + (SEQ (COND + ((AND (PAIRP |catform|) (EQ (QCAR |catform|) 'CATEGORY) + (PROGN + (SPADLET |ISTMP#1| (QCDR |catform|)) + (AND (PAIRP |ISTMP#1|) + (PROGN (SPADLET |r| (QCDR |ISTMP#1|)) 'T)))) + (PROG (G166477) + (SPADLET G166477 NIL) + (RETURN + (DO ((G166483 |r| (CDR G166483)) (|x| NIL)) + ((OR (ATOM G166483) + (PROGN (SETQ |x| (CAR G166483)) NIL)) + (NREVERSE0 G166477)) + (SEQ (EXIT (COND + ((AND (PAIRP |x|) + (EQ (QCAR |x|) 'ATTRIBUTE) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |y| + (QCAR |ISTMP#1|)) + 'T)))) + (SETQ G166477 (CONS |y| G166477)))))))))) + ((AND (PAIRP |catform|) (EQ (QCAR |catform|) '|Join|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |catform|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (REVERSE |ISTMP#1|)) + 'T) + (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |x| (QCAR |ISTMP#2|)) + (SPADLET |m| (QCDR |ISTMP#2|)) + 'T) + (PROGN (SPADLET |m| (NREVERSE |m|)) 'T)))) + (|getAttributesFromCATEGORY| |x|)) + ('T NIL)))))) + +;displayDatabase x == main where +; main == +; for y in +; '(CONSTRUCTORFORM CONSTRUCTORKIND _ +; CONSTRUCTORMODEMAP _ +; ABBREVIATION _ +; CONSTRUCTORCATEGORY _ +; PARENTS _ +; ATTRIBUTES _ +; ANCESTORS _ +; SOURCEFILE _ +; OPERATIONALIST _ +; MODEMAPS _ +; SOURCEFILE _ +; DOCUMENTATION) repeat fn(x,y) +; fn(x,y) == +; sayBrightly ['"----------------- ",y,'" --------------------"] +; pp GETDATABASE(x,y) + +(DEFUN |displayDatabase,fn| (|x| |y|) + (SEQ (|sayBrightly| + (CONS (MAKESTRING "----------------- ") + (CONS |y| + (CONS (MAKESTRING " --------------------") NIL)))) + (EXIT (|pp| (GETDATABASE |x| |y|))))) + +(DEFUN |displayDatabase| (|x|) + (SEQ (DO ((G166510 + '(CONSTRUCTORFORM CONSTRUCTORKIND CONSTRUCTORMODEMAP + ABBREVIATION CONSTRUCTORCATEGORY PARENTS + ATTRIBUTES ANCESTORS SOURCEFILE OPERATIONALIST + MODEMAPS SOURCEFILE DOCUMENTATION) + (CDR G166510)) + (|y| NIL)) + ((OR (ATOM G166510) + (PROGN (SETQ |y| (CAR G166510)) NIL)) + NIL) + (SEQ (EXIT (|displayDatabase,fn| |x| |y|)))))) + +;-- For some reason Dick has modified as.boot to convert the +;-- identifier |0| or |1| to an integer in the list of operations. +;-- This is WRONG, all existing code assumes that operation names +;-- are always identifiers not numbers. +;-- This function breaks the ability of the interpreter to find +;-- |0| or |1| as exports of new compiler domains. +;-- Unless someone has a strong reason for keeping the change, +;-- this function should be no-opped, i.e. +;-- zeroOneConversion opAlist == opAlist +;-- If this change is made, then we are able to find asharp constants again. +;-- bmt Mar 26, 1994 and executed by rss +;zeroOneConversion opAlist == opAlist + +(DEFUN |zeroOneConversion| (|opAlist|) |opAlist|) + +;-- for u in opAlist repeat +;-- [op,:.] := u +;-- DIGITP (PNAME op).0 => RPLACA(u, string2Integer PNAME op) +;-- opAlist +;asyDisplay(con,alist) == +; banner := '"==============================" +; sayBrightly [banner,'" ",con,'" ",banner] +; for [prop,:value] in alist repeat +; sayBrightlyNT [prop,'": "] +; pp value + +(DEFUN |asyDisplay| (|con| |alist|) + (PROG (|banner| |prop| |value|) + (RETURN + (SEQ (PROGN + (SPADLET |banner| + (MAKESTRING "==============================")) + (|sayBrightly| + (CONS |banner| + (CONS (MAKESTRING " ") + (CONS |con| + (CONS (MAKESTRING " ") + (CONS |banner| NIL)))))) + (DO ((G166534 |alist| (CDR G166534)) (G166523 NIL)) + ((OR (ATOM G166534) + (PROGN (SETQ G166523 (CAR G166534)) NIL) + (PROGN + (PROGN + (SPADLET |prop| (CAR G166523)) + (SPADLET |value| (CDR G166523)) + G166523) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (|sayBrightlyNT| + (CONS |prop| + (CONS (MAKESTRING ": ") NIL))) + (|pp| |value|)))))))))) + +;asGetModemaps(opAlist,oform,kind,modemap) == +; acc:= nil +; rpvl:= +; MEMQ(kind, '(category function)) => rest $PatternVariableList -- *1 is special for $ +; $PatternVariableList +; form := [opOf oform,:[y for x in KDR oform for y in rpvl]] +; dc := +; MEMQ(kind, '(category function)) => "*1" +; form +; pred1 := +; kind = 'category => [["*1",form]] +; nil +; signature := CDAR modemap +; domainList := +; [[a,m] for a in rest form for m in rest signature | +; asIsCategoryForm m] +; catPredList:= +; kind = 'function => [["isFreeFunction","*1",opOf form]] +; [['ofCategory,:u] for u in [:pred1,:domainList]] +;-- for [op,:itemlist] in SUBLISLIS(rpvl, $FormalMapVariableList,opAlist) repeat +;-- the code seems to oscillate between generating $FormalMapVariableList +;-- and generating $TriangleVariableList +; for [op,:itemlist] in SUBLISLIS(rpvl, $FormalMapVariableList,opAlist) repeat +; for [sig0, pred] in itemlist repeat +; sig := SUBST(dc,"$",sig0) +; pred:= SUBST(dc,"$",pred) +; sig := SUBLISLIS(rpvl,KDR oform,sig) +; pred:= SUBLISLIS(rpvl,KDR oform,pred) +; pred := pred or 'T +; ----------> Constants change <-------------- +; if IDENTP sig0 then +; sig := [sig] +; pred := MKPF([pred,'(isAsConstant)],'AND) +; pred' := MKPF([pred,:catPredList],'AND) +; mm := [[dc,:sig],[pred']] +; acc := [[op,:interactiveModemapForm mm],:acc] +; NREVERSE acc + +(DEFUN |asGetModemaps| (|opAlist| |oform| |kind| |modemap|) + (PROG (|rpvl| |form| |dc| |pred1| |signature| |domainList| + |catPredList| |op| |itemlist| |sig0| |sig| |pred| + |pred'| |mm| |acc|) + (declare (special |$FormalMapVariableList| |$PatternVariableList|)) + (RETURN + (SEQ (PROGN + (SPADLET |acc| NIL) + (SPADLET |rpvl| + (COND + ((MEMQ |kind| '(|category| |function|)) + (CDR |$PatternVariableList|)) + ('T |$PatternVariableList|))) + (SPADLET |form| + (CONS (|opOf| |oform|) + (PROG (G166567) + (SPADLET G166567 NIL) + (RETURN + (DO ((G166573 (KDR |oform|) + (CDR G166573)) + (|x| NIL) + (G166574 |rpvl| (CDR G166574)) + (|y| NIL)) + ((OR (ATOM G166573) + (PROGN + (SETQ |x| (CAR G166573)) + NIL) + (ATOM G166574) + (PROGN + (SETQ |y| (CAR G166574)) + NIL)) + (NREVERSE0 G166567)) + (SEQ (EXIT + (SETQ G166567 + (CONS |y| G166567))))))))) + (SPADLET |dc| + (COND + ((MEMQ |kind| '(|category| |function|)) '*1) + ('T |form|))) + (SPADLET |pred1| + (COND + ((BOOT-EQUAL |kind| '|category|) + (CONS (CONS '*1 (CONS |form| NIL)) NIL)) + ('T NIL))) + (SPADLET |signature| (CDAR |modemap|)) + (SPADLET |domainList| + (PROG (G166589) + (SPADLET G166589 NIL) + (RETURN + (DO ((G166596 (CDR |form|) (CDR G166596)) + (|a| NIL) + (G166597 (CDR |signature|) + (CDR G166597)) + (|m| NIL)) + ((OR (ATOM G166596) + (PROGN + (SETQ |a| (CAR G166596)) + NIL) + (ATOM G166597) + (PROGN + (SETQ |m| (CAR G166597)) + NIL)) + (NREVERSE0 G166589)) + (SEQ (EXIT (COND + ((|asIsCategoryForm| |m|) + (SETQ G166589 + (CONS + (CONS |a| (CONS |m| NIL)) + G166589)))))))))) + (SPADLET |catPredList| + (COND + ((BOOT-EQUAL |kind| '|function|) + (CONS (CONS '|isFreeFunction| + (CONS '*1 + (CONS (|opOf| |form|) NIL))) + NIL)) + ('T + (PROG (G166610) + (SPADLET G166610 NIL) + (RETURN + (DO ((G166615 + (APPEND |pred1| |domainList|) + (CDR G166615)) + (|u| NIL)) + ((OR (ATOM G166615) + (PROGN + (SETQ |u| (CAR G166615)) + NIL)) + (NREVERSE0 G166610)) + (SEQ (EXIT + (SETQ G166610 + (CONS (CONS '|ofCategory| |u|) + G166610)))))))))) + (DO ((G166637 + (SUBLISLIS |rpvl| |$FormalMapVariableList| + |opAlist|) + (CDR G166637)) + (G166557 NIL)) + ((OR (ATOM G166637) + (PROGN (SETQ G166557 (CAR G166637)) NIL) + (PROGN + (PROGN + (SPADLET |op| (CAR G166557)) + (SPADLET |itemlist| (CDR G166557)) + G166557) + NIL)) + NIL) + (SEQ (EXIT (DO ((G166657 |itemlist| (CDR G166657)) + (G166553 NIL)) + ((OR (ATOM G166657) + (PROGN + (SETQ G166553 (CAR G166657)) + NIL) + (PROGN + (PROGN + (SPADLET |sig0| (CAR G166553)) + (SPADLET |pred| + (CADR G166553)) + G166553) + NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |sig| + (MSUBST |dc| '$ |sig0|)) + (SPADLET |pred| + (MSUBST |dc| '$ |pred|)) + (SPADLET |sig| + (SUBLISLIS |rpvl| + (KDR |oform|) |sig|)) + (SPADLET |pred| + (SUBLISLIS |rpvl| + (KDR |oform|) |pred|)) + (SPADLET |pred| + (OR |pred| 'T)) + (COND + ((IDENTP |sig0|) + (SPADLET |sig| + (CONS |sig| NIL)) + (SPADLET |pred| + (MKPF + (CONS |pred| + (CONS '(|isAsConstant|) + NIL)) + 'AND)))) + (SPADLET |pred'| + (MKPF + (CONS |pred| |catPredList|) + 'AND)) + (SPADLET |mm| + (CONS (CONS |dc| |sig|) + (CONS (CONS |pred'| NIL) + NIL))) + (SPADLET |acc| + (CONS + (CONS |op| + (|interactiveModemapForm| + |mm|)) + |acc|))))))))) + (NREVERSE |acc|)))))) + +;asIsCategoryForm m == +; m = 'BasicType or GETDATABASE(opOf m,'CONSTRUCTORKIND) = 'category + +(DEFUN |asIsCategoryForm| (|m|) + (OR (BOOT-EQUAL |m| '|BasicType|) + (BOOT-EQUAL (GETDATABASE (|opOf| |m|) 'CONSTRUCTORKIND) + '|category|))) + +;asyDocumentation con == +; docHash := HGET($docHash,con) +; u := [[op,:[fn(x,op) for x in rec]] for op in HKEYS docHash +; | rec := HGET(docHash,op)] where fn(x,op) == +; [form,sig,pred,origin,where?,comments,:.] := x +; ----------> Constants change <-------------- +; if IDENTP sig then sig := [sig] +; [asySignature(sig,nil),trimComments comments] +; [form,sig,pred,origin,where?,comments] := first HGET($conHash,con) +; --above "first" assumes only one entry +; comments := trimComments asyExtractDescription comments +; [:u,['constructor,[nil,comments]]] + +(DEFUN |asyDocumentation,fn| (|x| |op|) + (declare (ignore |op|)) + (PROG (|form| |pred| |origin| |where?| |comments| |sig|) + (RETURN + (SEQ (PROGN + (SPADLET |form| (CAR |x|)) + (SPADLET |sig| (CADR |x|)) + (SPADLET |pred| (CADDR |x|)) + (SPADLET |origin| (CADDDR |x|)) + (SPADLET |where?| (CAR (CDDDDR |x|))) + (SPADLET |comments| (CADR (CDDDDR |x|))) + |x|) + (IF (IDENTP |sig|) (SPADLET |sig| (CONS |sig| NIL)) NIL) + (EXIT (CONS (|asySignature| |sig| NIL) + (CONS (|trimComments| |comments|) NIL))))))) + +(DEFUN |asyDocumentation| (|con|) + (PROG (|docHash| |rec| |u| |LETTMP#1| |form| |sig| |pred| |origin| + |where?| |comments|) + (declare (special |$conHash| |$docHash|)) + (RETURN + (SEQ (PROGN + (SPADLET |docHash| (HGET |$docHash| |con|)) + (SPADLET |u| + (PROG (G166735) + (SPADLET G166735 NIL) + (RETURN + (DO ((G166741 (HKEYS |docHash|) + (CDR G166741)) + (|op| NIL)) + ((OR (ATOM G166741) + (PROGN + (SETQ |op| (CAR G166741)) + NIL)) + (NREVERSE0 G166735)) + (SEQ (EXIT (COND + ((SPADLET |rec| + (HGET |docHash| |op|)) + (SETQ G166735 + (CONS + (CONS |op| + (PROG (G166751) + (SPADLET G166751 NIL) + (RETURN + (DO + ((G166756 |rec| + (CDR G166756)) + (|x| NIL)) + ((OR (ATOM G166756) + (PROGN + (SETQ |x| + (CAR G166756)) + NIL)) + (NREVERSE0 + G166751)) + (SEQ + (EXIT + (SETQ G166751 + (CONS + (|asyDocumentation,fn| + |x| |op|) + G166751)))))))) + G166735)))))))))) + (SPADLET |LETTMP#1| (CAR (HGET |$conHash| |con|))) + (SPADLET |form| (CAR |LETTMP#1|)) + (SPADLET |sig| (CADR |LETTMP#1|)) + (SPADLET |pred| (CADDR |LETTMP#1|)) + (SPADLET |origin| (CADDDR |LETTMP#1|)) + (SPADLET |where?| (CAR (CDDDDR |LETTMP#1|))) + (SPADLET |comments| (CADR (CDDDDR |LETTMP#1|))) + (SPADLET |comments| + (|trimComments| + (|asyExtractDescription| |comments|))) + (APPEND |u| + (CONS (CONS '|constructor| + (CONS (CONS NIL (CONS |comments| NIL)) + NIL)) + NIL))))))) + +;asyExtractDescription str == +; k := STRPOS('"Description:",str,0,nil) => asyExtractDescription SUBSTRING(str,k + 12,nil) +; k := STRPOS('"Author:",str,0,nil) => asyExtractDescription SUBSTRING(str,0,k) +; str + +(DEFUN |asyExtractDescription| (|str|) + (PROG (|k|) + (RETURN + (COND + ((SPADLET |k| (STRPOS (MAKESTRING "Description:") |str| 0 NIL)) + (|asyExtractDescription| (SUBSTRING |str| (PLUS |k| 12) NIL))) + ((SPADLET |k| (STRPOS (MAKESTRING "Author:") |str| 0 NIL)) + (|asyExtractDescription| (SUBSTRING |str| 0 |k|))) + ('T |str|))))) + +;trimComments str == +; null str or str = '"" => '"" +; m := MAXINDEX str +; str := SUBSTRING(str,0,m) +; trimString str + +(DEFUN |trimComments| (|str|) + (PROG (|m|) + (RETURN + (COND + ((OR (NULL |str|) (BOOT-EQUAL |str| (MAKESTRING ""))) + (MAKESTRING "")) + ('T (SPADLET |m| (MAXINDEX |str|)) + (SPADLET |str| (SUBSTRING |str| 0 |m|)) (|trimString| |str|)))))) + +;asyExportAlist con == +;--format of 'operationAlist property of LISPLIBS (as returned from koOps): +;-- +;-- +;--!!! asyFile NEED: need to know if function is implemented by domain!!! +; docHash := HGET($docHash,con) +; [[op,:[fn(x,op) for x in rec]] for op in HKEYS docHash | rec := HGET(docHash,op)] +; where fn(x,op) == +; [form,sig,pred,origin,where?,comments,:.] := x +; tail := +; pred => [pred] +; nil +; newSig := asySignature(sig,nil) +; [newSig,nil,:tail] + +(DEFUN |asyExportAlist,fn| (|x| |op|) + (declare (ignore |op|)) + (PROG (|form| |sig| |pred| |origin| |where?| |comments| |tail| + |newSig|) + (RETURN + (SEQ (PROGN + (SPADLET |form| (CAR |x|)) + (SPADLET |sig| (CADR |x|)) + (SPADLET |pred| (CADDR |x|)) + (SPADLET |origin| (CADDDR |x|)) + (SPADLET |where?| (CAR (CDDDDR |x|))) + (SPADLET |comments| (CADR (CDDDDR |x|))) + |x|) + (SPADLET |tail| + (SEQ (IF |pred| (EXIT (CONS |pred| NIL))) + (EXIT NIL))) + (SPADLET |newSig| (|asySignature| |sig| NIL)) + (EXIT (CONS |newSig| (CONS NIL |tail|))))))) + +(DEFUN |asyExportAlist| (|con|) + (PROG (|docHash| |rec|) + (declare (special |$docHash|)) + (RETURN + (SEQ (PROGN + (SPADLET |docHash| (HGET |$docHash| |con|)) + (PROG (G166817) + (SPADLET G166817 NIL) + (RETURN + (DO ((G166823 (HKEYS |docHash|) (CDR G166823)) + (|op| NIL)) + ((OR (ATOM G166823) + (PROGN (SETQ |op| (CAR G166823)) NIL)) + (NREVERSE0 G166817)) + (SEQ (EXIT (COND + ((SPADLET |rec| (HGET |docHash| |op|)) + (SETQ G166817 + (CONS + (CONS |op| + (PROG (G166833) + (SPADLET G166833 NIL) + (RETURN + (DO + ((G166838 |rec| + (CDR G166838)) + (|x| NIL)) + ((OR (ATOM G166838) + (PROGN + (SETQ |x| + (CAR G166838)) + NIL)) + (NREVERSE0 G166833)) + (SEQ + (EXIT + (SETQ G166833 + (CONS + (|asyExportAlist,fn| + |x| |op|) + G166833)))))))) + G166817)))))))))))))) + +;asyMakeOperationAlist(con,proplist, key) == +; oplist := +; u := LASSOC('domExports,proplist) => +; kind := 'domain +; u +; u := LASSOC('catExports,proplist) => +; kind := 'category +; u +; key = 'domain => +; kind := 'domain +; u := NIL +; return nil +; ht := MAKE_-HASH_-TABLE() +; ancestorAlist := nil +; for ['Declare,id,form,r] in oplist repeat +; id = "%%" => +; opOf form = con => nil +; y := asyAncestors form +; [attrs, na] := asyFindAttrs y +; y := na +; if opOf(y)^=con then ancestorAlist := [ [y,:true],:ancestorAlist] +; idForm := +; form is ['Apply,'_-_>,source,target] => [id,:asyArgs source] +; ----------> Constants change <-------------- +; id +; pred := +; LASSOC('condition,r) is p => hackToRemoveAnd p +; nil +; sig := asySignature(asytranForm(form,[idForm],nil),nil) +; entry := +; --id ^= "%%" and IDENTP idForm => [[sig],nil,nil,'ASCONST] +; id ^= "%%" and IDENTP idForm => +; pred => [[sig],nil,asyPredTran pred,'ASCONST] +; [[sig],nil,true,'ASCONST] +; pred => [sig,nil,asyPredTran pred] +; [sig] +; HPUT(ht,id,[entry,:HGET(ht,id)]) +; opalist := [[op,:REMDUP HGET(ht,op)] for op in HKEYS ht] +; --HPUT($opHash,con,[ancestorAlist,attributeAlist,:opalist]) +; HPUT($opHash,con,[ancestorAlist,nil,:opalist]) + +(DEFUN |asyMakeOperationAlist| (|con| |proplist| |key|) + (PROG (|kind| |u| |oplist| |ht| |id| |form| |r| |LETTMP#1| |attrs| + |na| |y| |ancestorAlist| |ISTMP#1| |ISTMP#2| |source| + |ISTMP#3| |target| |idForm| |p| |pred| |sig| |entry| + |opalist|) + (declare (special |$opHash|)) + (RETURN + (SEQ (PROGN + (SPADLET |oplist| + (COND + ((SPADLET |u| + (LASSOC '|domExports| |proplist|)) + (SPADLET |kind| '|domain|) |u|) + ((SPADLET |u| + (LASSOC '|catExports| |proplist|)) + (SPADLET |kind| '|category|) |u|) + ((BOOT-EQUAL |key| '|domain|) + (SPADLET |kind| '|domain|) (SPADLET |u| NIL)) + ('T (RETURN NIL)))) + (SPADLET |ht| (MAKE-HASH-TABLE)) + (SPADLET |ancestorAlist| NIL) + (DO ((G166914 |oplist| (CDR G166914)) (G166893 NIL)) + ((OR (ATOM G166914) + (PROGN (SETQ G166893 (CAR G166914)) NIL) + (PROGN + (PROGN + (SPADLET |id| (CADR G166893)) + (SPADLET |form| (CADDR G166893)) + (SPADLET |r| (CADDDR G166893)) + G166893) + NIL)) + NIL) + (SEQ (EXIT (COND + ((BOOT-EQUAL |id| '%%) + (COND + ((BOOT-EQUAL (|opOf| |form|) |con|) NIL) + ('T + (SPADLET |y| (|asyAncestors| |form|)) + (SPADLET |LETTMP#1| + (|asyFindAttrs| |y|)) + (SPADLET |attrs| (CAR |LETTMP#1|)) + (SPADLET |na| (CADR |LETTMP#1|)) + (SPADLET |y| |na|) + (COND + ((NEQUAL (|opOf| |y|) |con|) + (SPADLET |ancestorAlist| + (CONS (CONS |y| 'T) + |ancestorAlist|))) + ('T NIL))))) + ('T + (SPADLET |idForm| + (COND + ((AND (PAIRP |form|) + (EQ (QCAR |form|) '|Apply|) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |form|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '->) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |source| + (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND + (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) + NIL) + (PROGN + (SPADLET |target| + (QCAR |ISTMP#3|)) + 'T)))))))) + (CONS |id| + (|asyArgs| |source|))) + ('T |id|))) + (SPADLET |pred| + (COND + ((PROGN + (SPADLET |p| + (LASSOC '|condition| |r|)) + 'T) + (|hackToRemoveAnd| |p|)) + ('T NIL))) + (SPADLET |sig| + (|asySignature| + (|asytranForm| |form| + (CONS |idForm| NIL) NIL) + NIL)) + (SPADLET |entry| + (COND + ((AND (NEQUAL |id| '%%) + (IDENTP |idForm|)) + (COND + (|pred| + (CONS (CONS |sig| NIL) + (CONS NIL + (CONS + (|asyPredTran| |pred|) + (CONS 'ASCONST NIL))))) + ('T + (CONS (CONS |sig| NIL) + (CONS NIL + (CONS 'T + (CONS 'ASCONST NIL))))))) + (|pred| + (CONS |sig| + (CONS NIL + (CONS (|asyPredTran| |pred|) + NIL)))) + ('T (CONS |sig| NIL)))) + (HPUT |ht| |id| + (CONS |entry| (HGET |ht| |id|)))))))) + (SPADLET |opalist| + (PROG (G166925) + (SPADLET G166925 NIL) + (RETURN + (DO ((G166930 (HKEYS |ht|) (CDR G166930)) + (|op| NIL)) + ((OR (ATOM G166930) + (PROGN + (SETQ |op| (CAR G166930)) + NIL)) + (NREVERSE0 G166925)) + (SEQ (EXIT (SETQ G166925 + (CONS + (CONS |op| + (REMDUP (HGET |ht| |op|))) + G166925)))))))) + (HPUT |$opHash| |con| + (CONS |ancestorAlist| (CONS 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 + +(DEFUN |hackToRemoveAnd| (|p|) + (PROG (|ISTMP#1| |q| |r|) + (RETURN + (COND + ((AND (PAIRP |p|) (EQ (QCAR |p|) '|And|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |p|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |q| (QCAR |ISTMP#1|)) + (SPADLET |r| (QCDR |ISTMP#1|)) + 'T)))) + (COND (|r| (CONS 'AND (CONS |q| |r|))) ('T |q|))) + ('T |p|))))) + +;asyAncestors x == +; x is ['Apply,:r] => asyAncestorList r +; x is [op,y,:.] and MEMQ(op, '(PretendTo RestrictTo)) => asyAncestors y +; atom x => +; x = '_% => '_$ +; MEMQ(x, $niladics) => [x] +; GETDATABASE(x ,'NILADIC) => [x] +; x +; asyAncestorList x + +(DEFUN |asyAncestors| (|x|) + (PROG (|r| |op| |ISTMP#1| |y|) + (declare (special |$niladics|)) + (RETURN + (COND + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|Apply|) + (PROGN (SPADLET |r| (QCDR |x|)) 'T)) + (|asyAncestorList| |r|)) + ((AND (PAIRP |x|) + (PROGN + (SPADLET |op| (QCAR |x|)) + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN (SPADLET |y| (QCAR |ISTMP#1|)) 'T))) + (MEMQ |op| '(|PretendTo| |RestrictTo|))) + (|asyAncestors| |y|)) + ((ATOM |x|) + (COND + ((BOOT-EQUAL |x| '%) '$) + ((MEMQ |x| |$niladics|) (CONS |x| NIL)) + ((GETDATABASE |x| 'NILADIC) (CONS |x| NIL)) + ('T |x|))) + ('T (|asyAncestorList| |x|)))))) + +;asyAncestorList x == [asyAncestors y for y in x] + +(DEFUN |asyAncestorList| (|x|) + (PROG () + (RETURN + (SEQ (PROG (G167007) + (SPADLET G167007 NIL) + (RETURN + (DO ((G167012 |x| (CDR G167012)) (|y| NIL)) + ((OR (ATOM G167012) + (PROGN (SETQ |y| (CAR G167012)) NIL)) + (NREVERSE0 G167007)) + (SEQ (EXIT (SETQ G167007 + (CONS (|asyAncestors| |y|) G167007))))))))))) + +;--============================================================================ +;-- Build Operation Alist from sig +;--============================================================================ +;--format of operations as returned from koOps +;-- +;-- +;--abb,kind,file,sourcefile,coSig,dbLineNumber,constructorArgs,libfile +;--((sig where(NIL or #) condition(T or pred) ELTorSubsumed) ... +;--expanded lists are: sig, predicate, origin, exposeFlag, comments +;--============================================================================ +;-- Building Hash Tables for Operations/Constructors +;--============================================================================ +;asytran fn == +;--put operations into table format for browser: +;-- +; inStream := OPEN fn +; sayBrightly ['" Reading ",fn] +; u := READ inStream +; $niladics := mkNiladics u +; for x in $niladics repeat PUT(x,'NILADIC,true) +; for d in u repeat +; ['Declare,name,:.] := d +; name = "%%" => 'skip --skip over top-level properties +; $docHashLocal: local := MAKE_-HASH_-TABLE() +; asytranDeclaration(d,'(top),nil,false) +; if null name then hohohoho() +; HPUT($docHash,name,$docHashLocal) +; CLOSE inStream +; 'done + +(DEFUN |asytran| (|fn|) + (PROG (|$docHashLocal| |inStream| |u| |name|) + (DECLARE (SPECIAL |$docHashLocal| |$niladics| |$docHash|)) + (RETURN + (SEQ (PROGN + (SPADLET |inStream| (OPEN |fn|)) + (|sayBrightly| + (CONS (MAKESTRING " Reading ") (CONS |fn| NIL))) + (SPADLET |u| (VMREAD |inStream|)) + (SPADLET |$niladics| (|mkNiladics| |u|)) + (DO ((G167029 |$niladics| (CDR G167029)) (|x| NIL)) + ((OR (ATOM G167029) + (PROGN (SETQ |x| (CAR G167029)) NIL)) + NIL) + (SEQ (EXIT (PUT |x| 'NILADIC 'T)))) + (DO ((G167040 |u| (CDR G167040)) (|d| NIL)) + ((OR (ATOM G167040) + (PROGN (SETQ |d| (CAR G167040)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |name| (CADR |d|)) + (COND + ((BOOT-EQUAL |name| '%%) '|skip|) + ('T + (SPADLET |$docHashLocal| + (MAKE-HASH-TABLE)) + (|asytranDeclaration| |d| '(|top|) NIL + NIL) + (COND ((NULL |name|) (|hohohoho|))) + (HPUT |$docHash| |name| |$docHashLocal|))))))) + (CLOSE |inStream|) + '|done|))))) + +;mkNiladics u == +; [name for x in u | x is ['Declare,name,y,:.] and y isnt ['Apply,'_-_>,:.]] + +(DEFUN |mkNiladics| (|u|) + (PROG (|name| |ISTMP#2| |y| |ISTMP#1|) + (RETURN + (SEQ (PROG (G167079) + (SPADLET G167079 NIL) + (RETURN + (DO ((G167085 |u| (CDR G167085)) (|x| NIL)) + ((OR (ATOM G167085) + (PROGN (SETQ |x| (CAR G167085)) NIL)) + (NREVERSE0 G167079)) + (SEQ (EXIT (COND + ((AND (PAIRP |x|) + (EQ (QCAR |x|) '|Declare|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |name| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |y| + (QCAR |ISTMP#2|)) + 'T))))) + (NULL + (AND (PAIRP |y|) + (EQ (QCAR |y|) '|Apply|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |y|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '->)))))) + (SETQ G167079 (CONS |name| G167079))))))))))))) + +;--OLD DEFINITION FOLLOWS +;asytranDeclaration(dform,levels,predlist,local?) == +; ['Declare,id,form,r] := dform +; id = 'failed => id +; KAR dform ^= 'Declare => systemError '"asytranDeclaration" +; if levels = '(top) then +; if form isnt ['Apply,"->",:.] then HPUT($constantHash,id,true) +; comments := LASSOC('documentation,r) or '"" +; idForm := +; levels is ['top,:.] => +; form is ['Apply,'_-_>,source,target] => [id,:asyArgs source] +; id +; ----------> Constants change <-------------- +; id +; newsig := asytranForm(form,[idForm,:levels],local?) +; key := +; levels is ['top,:.] => +; MEMQ(id,'(%% Category Type)) => 'constant +; asyLooksLikeCatForm? form => 'category +; form is ['Apply, '_-_>,.,u] => +; if u is ['Apply, construc,:.] then u:= construc +; GETDATABASE(opOf u,'CONSTRUCTORKIND) = 'domain => 'function +; asyLooksLikeCatForm? u => 'category +; 'domain +; 'domain +; first levels +; typeCode := LASSOC('symeTypeCode,r) +; record := [idForm,newsig,asyMkpred predlist,key,true,comments,typeCode,:$asyFile] +; if not local? then +; ht := +; levels = '(top) => $conHash +; $docHashLocal +; HPUT(ht,id,[record,:HGET(ht,id)]) +; if levels = '(top) then asyMakeOperationAlist(id,r, key) +; ['Declare,id,newsig,r] + +(DEFUN |asytranDeclaration| (|dform| |levels| |predlist| |local?|) + (PROG (|id| |form| |r| |comments| |source| |target| |idForm| |newsig| + |ISTMP#2| |ISTMP#3| |ISTMP#1| |construc| |u| |key| + |typeCode| |record| |ht|) + (declare (special |$docHashLocal| |$conHash| |$asyFile| |$constantHash|)) + (RETURN + (PROGN + (SPADLET |id| (CADR |dform|)) + (SPADLET |form| (CADDR |dform|)) + (SPADLET |r| (CADDDR |dform|)) + (COND + ((BOOT-EQUAL |id| '|failed|) |id|) + ((NEQUAL (KAR |dform|) '|Declare|) + (|systemError| (MAKESTRING "asytranDeclaration"))) + ('T + (COND + ((BOOT-EQUAL |levels| '(|top|)) + (COND + ((NULL (AND (PAIRP |form|) (EQ (QCAR |form|) '|Apply|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |form|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '->))))) + (HPUT |$constantHash| |id| 'T)) + ('T NIL)))) + (SPADLET |comments| + (OR (LASSOC '|documentation| |r|) (MAKESTRING ""))) + (SPADLET |idForm| + (COND + ((AND (PAIRP |levels|) + (EQ (QCAR |levels|) '|top|)) + (COND + ((AND (PAIRP |form|) + (EQ (QCAR |form|) '|Apply|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |form|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '->) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |source| + (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET |target| + (QCAR |ISTMP#3|)) + 'T)))))))) + (CONS |id| (|asyArgs| |source|))) + ('T |id|))) + ('T |id|))) + (SPADLET |newsig| + (|asytranForm| |form| (CONS |idForm| |levels|) + |local?|)) + (SPADLET |key| + (COND + ((AND (PAIRP |levels|) + (EQ (QCAR |levels|) '|top|)) + (COND + ((MEMQ |id| '(%% |Category| |Type|)) + '|constant|) + ((|asyLooksLikeCatForm?| |form|) '|category|) + ((AND (PAIRP |form|) + (EQ (QCAR |form|) '|Apply|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |form|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '->) + (PROGN + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET |u| + (QCAR |ISTMP#3|)) + 'T)))))))) + (COND + ((AND (PAIRP |u|) (EQ (QCAR |u|) '|Apply|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |u|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |construc| + (QCAR |ISTMP#1|)) + 'T)))) + (SPADLET |u| |construc|))) + (COND + ((BOOT-EQUAL + (GETDATABASE (|opOf| |u|) + 'CONSTRUCTORKIND) + '|domain|) + '|function|) + ((|asyLooksLikeCatForm?| |u|) '|category|) + ('T '|domain|))) + ('T '|domain|))) + ('T (CAR |levels|)))) + (SPADLET |typeCode| (LASSOC '|symeTypeCode| |r|)) + (SPADLET |record| + (CONS |idForm| + (CONS |newsig| + (CONS (|asyMkpred| |predlist|) + (CONS |key| + (CONS 'T + (CONS |comments| + (CONS |typeCode| |$asyFile|)))))))) + (COND + ((NULL |local?|) + (SPADLET |ht| + (COND + ((BOOT-EQUAL |levels| '(|top|)) |$conHash|) + ('T |$docHashLocal|))) + (HPUT |ht| |id| (CONS |record| (HGET |ht| |id|))))) + (COND + ((BOOT-EQUAL |levels| '(|top|)) + (|asyMakeOperationAlist| |id| |r| |key|))) + (CONS '|Declare| (CONS |id| (CONS |newsig| (CONS |r| NIL)))))))))) + +;asyLooksLikeCatForm? x == +;--TTT don't see a Third in my version .... +; x is ['Define, ['Declare, ., ['Apply, 'Third,:.],:.],:.] or +; x is ['Define, ['Declare, ., 'Category ],:.] + +(DEFUN |asyLooksLikeCatForm?| (|x|) + (PROG (|ISTMP#5| |ISTMP#6| |ISTMP#1| |ISTMP#2| |ISTMP#3| |ISTMP#4|) + (RETURN + (OR (AND (PAIRP |x|) (EQ (QCAR |x|) '|Define|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCAR |ISTMP#2|) '|Declare|) + (PROGN + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |ISTMP#4| + (QCDR |ISTMP#3|)) + (AND (PAIRP |ISTMP#4|) + (PROGN + (SPADLET |ISTMP#5| + (QCAR |ISTMP#4|)) + (AND (PAIRP |ISTMP#5|) + (EQ (QCAR |ISTMP#5|) + '|Apply|) + (PROGN + (SPADLET |ISTMP#6| + (QCDR |ISTMP#5|)) + (AND (PAIRP |ISTMP#6|) + (EQ (QCAR |ISTMP#6|) + '|Third|)))))))))))))) + (AND (PAIRP |x|) (EQ (QCAR |x|) '|Define|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCAR |ISTMP#2|) '|Declare|) + (PROGN + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |ISTMP#4| + (QCDR |ISTMP#3|)) + (AND (PAIRP |ISTMP#4|) + (EQ (QCDR |ISTMP#4|) NIL) + (EQ (QCAR |ISTMP#4|) + '|Category|)))))))))))))) + +;--asytranDeclaration(dform,levels,predlist,local?) == +;-- ['Declare,id,form,r] := dform +;-- id = 'failed => id +;-- levels isnt ['top,:.] => asytranForm(form,[id,:levels],local?) +;-- idForm := +;-- form is ['Apply,'_-_>,source,target] => [id,:asyArgs source] +;-- id +;-- if form isnt ['Apply,"->",:.] then HPUT($constantHash,id,true) +;-- comments := LASSOC('documentation,r) or '"" +;-- newsig := asytranForm(form,[idForm,:levels],local?) +;-- key := +;-- MEMQ(id,'(%% Category Type)) => 'constant +;-- form is ['Apply,'Third,:.] => 'category +;-- form is ['Apply,.,.,target] and target is ['Apply,name,:.] +;-- and MEMQ(name,'(Third Join)) => 'category +;-- 'domain +;-- record := [newsig,asyMkpred predlist,key,true,comments,:$asyFile] +;-- if not local? then +;-- ht := +;-- levels = '(top) => $conHash +;-- $docHashLocal +;-- HPUT(ht,id,[record,:HGET(ht,id)]) +;-- if levels = '(top) then asyMakeOperationAlist(id,r) +;-- ['Declare,id,newsig,r] +;asyIsCatForm form == +; form is ['Apply,:r] => +; r is ['_-_>,.,a] => asyIsCatForm a +; r is ['Third,'Type,:.] => true +; false +; false + +(DEFUN |asyIsCatForm| (|form|) + (PROG (|r| |ISTMP#2| |a| |ISTMP#1|) + (RETURN + (COND + ((AND (PAIRP |form|) (EQ (QCAR |form|) '|Apply|) + (PROGN (SPADLET |r| (QCDR |form|)) 'T)) + (COND + ((AND (PAIRP |r|) (EQ (QCAR |r|) '->) + (PROGN + (SPADLET |ISTMP#1| (QCDR |r|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |a| (QCAR |ISTMP#2|)) + 'T)))))) + (|asyIsCatForm| |a|)) + ((AND (PAIRP |r|) (EQ (QCAR |r|) '|Third|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |r|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) '|Type|)))) + 'T) + ('T NIL))) + ('T NIL))))) + +;asyArgs source == +; args := +; source is [op,:u] and asyComma? op => u +; [source] +; [asyArg x for x in args] + +(DEFUN |asyArgs| (|source|) + (PROG (|op| |u| |args|) + (RETURN + (SEQ (PROGN + (SPADLET |args| + (COND + ((AND (PAIRP |source|) + (PROGN + (SPADLET |op| (QCAR |source|)) + (SPADLET |u| (QCDR |source|)) + 'T) + (|asyComma?| |op|)) + |u|) + ('T (CONS |source| NIL)))) + (PROG (G167293) + (SPADLET G167293 NIL) + (RETURN + (DO ((G167298 |args| (CDR G167298)) (|x| NIL)) + ((OR (ATOM G167298) + (PROGN (SETQ |x| (CAR G167298)) NIL)) + (NREVERSE0 G167293)) + (SEQ (EXIT (SETQ G167293 + (CONS (|asyArg| |x|) G167293)))))))))))) + +;asyArg x == +; x is ['Declare,id,:.] => id +; x + +(DEFUN |asyArg| (|x|) + (PROG (|ISTMP#1| |id|) + (RETURN + (COND + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|Declare|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN (SPADLET |id| (QCAR |ISTMP#1|)) 'T)))) + |id|) + ('T |x|))))) + +;asyMkpred predlist == +; null predlist => nil +; predlist is [p] => p +; ['AND,:predlist] + +(DEFUN |asyMkpred| (|predlist|) + (PROG (|p|) + (RETURN + (COND + ((NULL |predlist|) NIL) + ((AND (PAIRP |predlist|) (EQ (QCDR |predlist|) NIL) + (PROGN (SPADLET |p| (QCAR |predlist|)) 'T)) + |p|) + ('T (CONS 'AND |predlist|)))))) + +;asytranForm(form,levels,local?) == +; u := asytranForm1(form,levels,local?) +; null u => hahah() +; u + +(DEFUN |asytranForm| (|form| |levels| |local?|) + (PROG (|u|) + (RETURN + (PROGN + (SPADLET |u| (|asytranForm1| |form| |levels| |local?|)) + (COND ((NULL |u|) (|hahah|)) ('T |u|)))))) + +;asytranForm1(form,levels,local?) == +; form is ['With,left,cat] => +;-- left ^= nil => error '"WITH cannot take a left argument yet" +; asytranCategory(form,levels,nil,local?) +; form is ['Apply,:.] => asytranApply(form,levels,local?) +; form is ['Declare,:.] => asytranDeclaration(form,levels,nil,local?) +; form is ['Comma,:r] => ['Comma,:[asytranForm(x,levels,local?) for x in r]] +;--form is ['_-_>,:s] => asytranMapping(s,levels,local?) +; form is [op,a,b] and MEMQ(a,'(PretendTo RestrictTo)) => +; asytranForm1(a,levels,local?) +; form is ['LitInteger,s] => +; READ_-FROM_-STRING(s) +; form is ['Define,:.] => +; form is ['Define,['Declare,.,x,:.],rest] => +;--TTT i don't know about this one but looks ok +; x = 'Category => asytranForm1(rest,levels, local?) +; asytranForm1(x,levels,local?) +; error '"DEFINE forms are not handled yet" +; if form = '_% then $hasPerCent := true +; IDENTP form => +; form = "%" => "$" +; GET(form,'NILADIC) => [form] +; form +; [asytranForm(x,levels,local?) for x in form] + +(DEFUN |asytranForm1| (|form| |levels| |local?|) + (PROG (|left| |cat| |r| |op| |a| |b| |s| |ISTMP#1| |ISTMP#2| + |ISTMP#3| |ISTMP#4| |x| |ISTMP#5| CDR) + (declare (special |$hasPerCent|)) + (RETURN + (SEQ (COND + ((AND (PAIRP |form|) (EQ (QCAR |form|) '|With|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |form|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |left| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |cat| (QCAR |ISTMP#2|)) + 'T)))))) + (|asytranCategory| |form| |levels| NIL |local?|)) + ((AND (PAIRP |form|) (EQ (QCAR |form|) '|Apply|)) + (|asytranApply| |form| |levels| |local?|)) + ((AND (PAIRP |form|) (EQ (QCAR |form|) '|Declare|)) + (|asytranDeclaration| |form| |levels| NIL |local?|)) + ((AND (PAIRP |form|) (EQ (QCAR |form|) '|Comma|) + (PROGN (SPADLET |r| (QCDR |form|)) 'T)) + (CONS '|Comma| + (PROG (G167419) + (SPADLET G167419 NIL) + (RETURN + (DO ((G167424 |r| (CDR G167424)) (|x| NIL)) + ((OR (ATOM G167424) + (PROGN + (SETQ |x| (CAR G167424)) + NIL)) + (NREVERSE0 G167419)) + (SEQ (EXIT (SETQ G167419 + (CONS + (|asytranForm| |x| |levels| + |local?|) + G167419))))))))) + ((AND (PAIRP |form|) + (PROGN + (SPADLET |op| (QCAR |form|)) + (SPADLET |ISTMP#1| (QCDR |form|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |b| (QCAR |ISTMP#2|)) + 'T))))) + (MEMQ |a| '(|PretendTo| |RestrictTo|))) + (|asytranForm1| |a| |levels| |local?|)) + ((AND (PAIRP |form|) (EQ (QCAR |form|) '|LitInteger|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |form|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |s| (QCAR |ISTMP#1|)) 'T)))) + (READ-FROM-STRING |s|)) + ((AND (PAIRP |form|) (EQ (QCAR |form|) '|Define|)) + (COND + ((AND (PAIRP |form|) (EQ (QCAR |form|) '|Define|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |form|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCAR |ISTMP#2|) '|Declare|) + (PROGN + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (PROGN + (SPADLET |ISTMP#4| + (QCDR |ISTMP#3|)) + (AND (PAIRP |ISTMP#4|) + (PROGN + (SPADLET |x| + (QCAR |ISTMP#4|)) + 'T))))))) + (PROGN + (SPADLET |ISTMP#5| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#5|) + (EQ (QCDR |ISTMP#5|) NIL) + (PROGN + (SPADLET CDR (QCAR |ISTMP#5|)) + 'T)))))) + (COND + ((BOOT-EQUAL |x| '|Category|) + (|asytranForm1| CDR |levels| |local?|)) + ('T (|asytranForm1| |x| |levels| |local?|)))) + ('T + (|error| (MAKESTRING + "DEFINE forms are not handled yet"))))) + ('T + (COND + ((BOOT-EQUAL |form| '%) (SPADLET |$hasPerCent| 'T))) + (COND + ((IDENTP |form|) + (COND + ((BOOT-EQUAL |form| '%) '$) + ((GETL |form| 'NILADIC) (CONS |form| NIL)) + ('T |form|))) + ('T + (PROG (G167434) + (SPADLET G167434 NIL) + (RETURN + (DO ((G167439 |form| (CDR G167439)) (|x| NIL)) + ((OR (ATOM G167439) + (PROGN (SETQ |x| (CAR G167439)) NIL)) + (NREVERSE0 G167434)) + (SEQ (EXIT (SETQ G167434 + (CONS + (|asytranForm| |x| |levels| + |local?|) + G167434))))))))))))))) + +;asytranApply(['Apply,name,:arglist],levels,local?) == +; MEMQ(name,'(Record Union)) => +; [name,:[asytranApplySpecial(x, levels, local?) for x in arglist]] +; null arglist => [name] +; name is [ 'RestrictTo, :.] => +; asytranApply(['Apply, CAR CDR name,:arglist], levels, local?) +; name is [ 'Qualify, :.] => +; asytranApply(['Apply, CAR CDR name,:arglist], levels, local?) +; name is 'string => asytranLiteral CAR arglist +; name is 'integer => asytranLiteral CAR arglist +; name is 'float => asytranLiteral CAR arglist +; name = 'Enumeration => +; ["Enumeration",:[asytranEnumItem arg for arg in arglist]] +; [:argl,lastArg] := arglist +; [name,:[asytranFormSpecial(arg,levels,true) for arg in argl], +; asytranFormSpecial(lastArg,levels,false)] + +(DEFUN |asytranApply| (G167475 |levels| |local?|) + (PROG (|name| |arglist| |LETTMP#1| |lastArg| |argl|) + (RETURN + (SEQ (PROGN + (SPADLET |name| (CADR G167475)) + (SPADLET |arglist| (CDDR G167475)) + (COND + ((MEMQ |name| '(|Record| |Union|)) + (CONS |name| + (PROG (G167492) + (SPADLET G167492 NIL) + (RETURN + (DO ((G167497 |arglist| (CDR G167497)) + (|x| NIL)) + ((OR (ATOM G167497) + (PROGN + (SETQ |x| (CAR G167497)) + NIL)) + (NREVERSE0 G167492)) + (SEQ (EXIT (SETQ G167492 + (CONS + (|asytranApplySpecial| |x| + |levels| |local?|) + G167492))))))))) + ((NULL |arglist|) (CONS |name| NIL)) + ((AND (PAIRP |name|) (EQ (QCAR |name|) '|RestrictTo|)) + (|asytranApply| + (CONS '|Apply| (CONS (CAR (CDR |name|)) |arglist|)) + |levels| |local?|)) + ((AND (PAIRP |name|) (EQ (QCAR |name|) '|Qualify|)) + (|asytranApply| + (CONS '|Apply| (CONS (CAR (CDR |name|)) |arglist|)) + |levels| |local?|)) + ((EQ |name| '|string|) + (|asytranLiteral| (CAR |arglist|))) + ((EQ |name| '|integer|) + (|asytranLiteral| (CAR |arglist|))) + ((EQ |name| '|float|) + (|asytranLiteral| (CAR |arglist|))) + ((BOOT-EQUAL |name| '|Enumeration|) + (CONS '|Enumeration| + (PROG (G167507) + (SPADLET G167507 NIL) + (RETURN + (DO ((G167512 |arglist| (CDR G167512)) + (|arg| NIL)) + ((OR (ATOM G167512) + (PROGN + (SETQ |arg| (CAR G167512)) + NIL)) + (NREVERSE0 G167507)) + (SEQ (EXIT (SETQ G167507 + (CONS (|asytranEnumItem| |arg|) + G167507))))))))) + ('T (SPADLET |LETTMP#1| (REVERSE |arglist|)) + (SPADLET |lastArg| (CAR |LETTMP#1|)) + (SPADLET |argl| (NREVERSE (CDR |LETTMP#1|))) + (CONS |name| + (APPEND (PROG (G167522) + (SPADLET G167522 NIL) + (RETURN + (DO ((G167527 |argl| + (CDR G167527)) + (|arg| NIL)) + ((OR (ATOM G167527) + (PROGN + (SETQ |arg| (CAR G167527)) + NIL)) + (NREVERSE0 G167522)) + (SEQ + (EXIT + (SETQ G167522 + (CONS + (|asytranFormSpecial| |arg| + |levels| 'T) + G167522))))))) + (CONS (|asytranFormSpecial| |lastArg| + |levels| NIL) + NIL)))))))))) + +;asytranLiteral(lit) == +; CAR CDR lit + +(DEFUN |asytranLiteral| (|lit|) (CAR (CDR |lit|))) + +;asytranEnumItem arg == +; arg is ['Declare, name, :.] => name +; error '"Bad Enumeration entry" + +(DEFUN |asytranEnumItem| (|arg|) + (PROG (|ISTMP#1| |name|) + (RETURN + (COND + ((AND (PAIRP |arg|) (EQ (QCAR |arg|) '|Declare|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |arg|)) + (AND (PAIRP |ISTMP#1|) + (PROGN (SPADLET |name| (QCAR |ISTMP#1|)) 'T)))) + |name|) + ('T (|error| (MAKESTRING "Bad Enumeration entry"))))))) + +;asytranApplySpecial(x, levels, local?) == +; x is ['Declare, name, typ, :.] => [":",name,asytranForm(typ, levels, local?)] +; asytranForm(x, levels, local?) + +(DEFUN |asytranApplySpecial| (|x| |levels| |local?|) + (PROG (|ISTMP#1| |name| |ISTMP#2| |typ|) + (RETURN + (COND + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|Declare|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |name| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |typ| (QCAR |ISTMP#2|)) + 'T)))))) + (CONS '|:| + (CONS |name| + (CONS (|asytranForm| |typ| |levels| |local?|) NIL)))) + ('T (|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?) + +(DEFUN |asytranFormSpecial| (|x| |levels| |local?|) + (PROG (|ISTMP#1| |name| |ISTMP#2| |typ|) + (RETURN + (COND + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|Declare|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |name| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |typ| (QCAR |ISTMP#2|)) + 'T)))))) + (|asytranForm| |typ| |levels| |local?|)) + ('T (|asytranForm| |x| |levels| |local?|)))))) + +;asytranCategory(form,levels,predlist,local?) == +; cat := +; form is ['With,left,right] => +; right is ['Blank,:.] => ['Sequence] +; right +; form +; left := +; form is ['With,left,right] => +; left is ['Blank,:.] => nil +; left +; nil +; $hasPerCent: local := nil +; items := +; cat is ['Sequence,:s] => s +; [cat] +; catTable := MAKE_-HASH_-TABLE() +; catList := nil +; for x in items | x repeat +; if null x then systemError() +; dform := asytranCategoryItem(x,levels,predlist,local?) +; null dform => nil +; dform is ['Declare,id,record,r] => +; HPUT(catTable,id,[asyWrap(record,predlist),:HGET(catTable,id)]) +; catList := [asyWrap(dform,predlist),:catList] +; keys := listSort(function GLESSEQP,HKEYS catTable) +; right1 := NREVERSE catList +; right2 := [[key,:HGET(catTable,key)] for key in keys] +; right := +; right2 => [:right1,['Exports,:right2]] +; right1 +; res := +; left => [left,:right] +; right +; res is [x] and x is ['IF,:.] => x +; ['With,:res] + +(DEFUN |asytranCategory| (|form| |levels| |predlist| |local?|) + (PROG (|$hasPerCent| |cat| |left| |s| |items| |catTable| |dform| + |ISTMP#1| |id| |ISTMP#2| |record| |ISTMP#3| |r| |catList| + |keys| |right1| |right2| |right| |res| |x|) + (DECLARE (SPECIAL |$hasPerCent|)) + (RETURN + (SEQ (PROGN + (SPADLET |cat| + (COND + ((AND (PAIRP |form|) (EQ (QCAR |form|) '|With|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |form|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |left| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |right| + (QCAR |ISTMP#2|)) + 'T)))))) + (COND + ((AND (PAIRP |right|) + (EQ (QCAR |right|) '|Blank|)) + (CONS '|Sequence| NIL)) + ('T |right|))) + ('T |form|))) + (SPADLET |left| + (COND + ((AND (PAIRP |form|) (EQ (QCAR |form|) '|With|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |form|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |left| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |right| + (QCAR |ISTMP#2|)) + 'T)))))) + (COND + ((AND (PAIRP |left|) + (EQ (QCAR |left|) '|Blank|)) + NIL) + ('T |left|))) + ('T NIL))) + (SPADLET |$hasPerCent| NIL) + (SPADLET |items| + (COND + ((AND (PAIRP |cat|) + (EQ (QCAR |cat|) '|Sequence|) + (PROGN (SPADLET |s| (QCDR |cat|)) 'T)) + |s|) + ('T (CONS |cat| NIL)))) + (SPADLET |catTable| (MAKE-HASH-TABLE)) + (SPADLET |catList| NIL) + (DO ((G167697 |items| (CDR G167697)) (|x| NIL)) + ((OR (ATOM G167697) + (PROGN (SETQ |x| (CAR G167697)) NIL)) + NIL) + (SEQ (EXIT (COND + (|x| (PROGN + (COND ((NULL |x|) (|systemError|))) + (SPADLET |dform| + (|asytranCategoryItem| |x| |levels| + |predlist| |local?|)) + (COND + ((NULL |dform|) NIL) + ((AND (PAIRP |dform|) + (EQ (QCAR |dform|) '|Declare|) + (PROGN + (SPADLET |ISTMP#1| + (QCDR |dform|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |id| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |record| + (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) + NIL) + (PROGN + (SPADLET |r| + (QCAR |ISTMP#3|)) + 'T)))))))) + (HPUT |catTable| |id| + (CONS + (|asyWrap| |record| |predlist|) + (HGET |catTable| |id|)))) + ('T + (SPADLET |catList| + (CONS + (|asyWrap| |dform| |predlist|) + |catList|)))))))))) + (SPADLET |keys| + (|listSort| (|function| GLESSEQP) + (HKEYS |catTable|))) + (SPADLET |right1| (NREVERSE |catList|)) + (SPADLET |right2| + (PROG (G167707) + (SPADLET G167707 NIL) + (RETURN + (DO ((G167712 |keys| (CDR G167712)) + (|key| NIL)) + ((OR (ATOM G167712) + (PROGN + (SETQ |key| (CAR G167712)) + NIL)) + (NREVERSE0 G167707)) + (SEQ (EXIT (SETQ G167707 + (CONS + (CONS |key| + (HGET |catTable| |key|)) + G167707)))))))) + (SPADLET |right| + (COND + (|right2| + (APPEND |right1| + (CONS (CONS '|Exports| |right2|) + NIL))) + ('T |right1|))) + (SPADLET |res| + (COND + (|left| (CONS |left| |right|)) + ('T |right|))) + (COND + ((AND (PAIRP |res|) (EQ (QCDR |res|) NIL) + (PROGN (SPADLET |x| (QCAR |res|)) 'T) (PAIRP |x|) + (EQ (QCAR |x|) 'IF)) + |x|) + ('T (CONS '|With| |res|)))))))) + +;asyWrap(record,predlist) == +; predlist => ['IF,MKPF(predlist,'AND),record] +; record + +(DEFUN |asyWrap| (|record| |predlist|) + (COND + (|predlist| + (CONS 'IF (CONS (MKPF |predlist| 'AND) (CONS |record| NIL)))) + ('T |record|))) + +;asytranCategoryItem(x,levels,predlist,local?) == +; x is ['If,predicate,item,:r] => +; IFCAR r => error '"ELSE expressions not allowed yet in conditionals" +; pred := +; predicate is ['Test,r] => r +; predicate +; asytranCategory(item,levels,[pred,:predlist],local?) +; MEMQ(KAR x,'(Default Foreign)) => nil +; x is ['Declare,:.] => asytranDeclaration(x,levels,predlist,local?) +; x + +(DEFUN |asytranCategoryItem| (|x| |levels| |predlist| |local?|) + (PROG (|predicate| |ISTMP#2| |item| |ISTMP#1| |r| |pred|) + (RETURN + (COND + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|If|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |predicate| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |item| (QCAR |ISTMP#2|)) + (SPADLET |r| (QCDR |ISTMP#2|)) + 'T)))))) + (COND + ((IFCAR |r|) + (|error| (MAKESTRING + "ELSE expressions not allowed yet in conditionals"))) + ('T + (SPADLET |pred| + (COND + ((AND (PAIRP |predicate|) + (EQ (QCAR |predicate|) '|Test|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |predicate|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |r| (QCAR |ISTMP#1|)) + 'T)))) + |r|) + ('T |predicate|))) + (|asytranCategory| |item| |levels| (CONS |pred| |predlist|) + |local?|)))) + ((MEMQ (KAR |x|) '(|Default| |Foreign|)) NIL) + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|Declare|)) + (|asytranDeclaration| |x| |levels| |predlist| |local?|)) + ('T |x|))))) + +;--============================================================================ +;-- Extending Constructor Datatable +;--============================================================================ +;--FORMAT of $constructorDataTable entry: +;--abb kind libFile sourceFile coSig constructorArgs +;--alist is ((kind . domain) (libFile . MATRIX) (sourceFile . "matrix") +;-- (coSig NIL T) (dbLineNumber . 29187) (constructorArgs R) +;-- (modemap . ( +;-- (|Matrix| |#1|) +;-- (Join (MatrixCategory #1 (Vector #1) (Vector #1)) +;-- (CATEGORY domain +;-- (SIGNATURE diagonalMatrix ($ (Vector #1))) +;-- (IF (has #1 (Field)) +;-- (SIGNATURE inverse ((Union $ "failed") $)) noBranch))) +;-- (Ring)) +;-- (T Matrix)) ) +;extendConstructorDataTable() == +;-- tb := $constructorDataTable +; for x in listSort(function GLESSEQP,HKEYS $conHash) repeat +;-- if LASSOC(x,tb) then tb := DELLASOS(x,tb) +; record := HGET($conHash,x) +; [form,sig,predlist,origin,exposure,comments,typeCode,:filename] := first record +; abb := asyAbbreviation(x,#(rest sig)) +; kind := 'domain +; --Note: this "first" assumes that there is ONLY one sig per name +; cosig := [nil,:asyCosig sig] +; args := asyConstructorArgs sig +; tb := +; [[x,abb, +; ['kind,:kind], +; ['cosig,:cosig], +; ['libfile,filename], +; ['sourceFile,STRINGIMAGE filename], +; ['constructorArgs,:args]],:tb] +; listSort(function GLESSEQP,ASSOCLEFT tb) + +(DEFUN |extendConstructorDataTable| () + (PROG (|record| |LETTMP#1| |form| |sig| |predlist| |origin| + |exposure| |comments| |typeCode| |filename| |abb| |kind| + |cosig| |args| |tb|) + (declare (special |$conHash|)) + (RETURN + (SEQ (PROGN + (DO ((G167836 + (|listSort| (|function| GLESSEQP) + (HKEYS |$conHash|)) + (CDR G167836)) + (|x| NIL)) + ((OR (ATOM G167836) + (PROGN (SETQ |x| (CAR G167836)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |record| (HGET |$conHash| |x|)) + (SPADLET |LETTMP#1| (CAR |record|)) + (SPADLET |form| (CAR |LETTMP#1|)) + (SPADLET |sig| (CADR |LETTMP#1|)) + (SPADLET |predlist| (CADDR |LETTMP#1|)) + (SPADLET |origin| (CADDDR |LETTMP#1|)) + (SPADLET |exposure| + (CAR (CDDDDR |LETTMP#1|))) + (SPADLET |comments| + (CADR (CDDDDR |LETTMP#1|))) + (SPADLET |typeCode| + (CADDR (CDDDDR |LETTMP#1|))) + (SPADLET |filename| + (CDDDR (CDDDDR |LETTMP#1|))) + (SPADLET |abb| + (|asyAbbreviation| |x| + (|#| (CDR |sig|)))) + (SPADLET |kind| '|domain|) + (SPADLET |cosig| + (CONS NIL (|asyCosig| |sig|))) + (SPADLET |args| + (|asyConstructorArgs| |sig|)) + (SPADLET |tb| + (CONS + (CONS |x| + (CONS |abb| + (CONS (CONS '|kind| |kind|) + (CONS (CONS '|cosig| |cosig|) + (CONS + (CONS '|libfile| + (CONS |filename| NIL)) + (CONS + (CONS '|sourceFile| + (CONS + (STRINGIMAGE |filename|) + NIL)) + (CONS + (CONS '|constructorArgs| + |args|) + NIL))))))) + |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] + +(DEFUN |asyConstructorArgs| (|sig|) + (PROG (|ISTMP#1| |source| |ISTMP#2| |target| |op| |argl|) + (RETURN + (SEQ (COND + ((AND (PAIRP |sig|) (EQ (QCAR |sig|) '|With|)) NIL) + ((AND (PAIRP |sig|) (EQ (QCAR |sig|) '->) + (PROGN + (SPADLET |ISTMP#1| (QCDR |sig|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |source| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |target| (QCAR |ISTMP#2|)) + 'T)))))) + (COND + ((AND (PAIRP |source|) + (PROGN + (SPADLET |op| (QCAR |source|)) + (SPADLET |argl| (QCDR |source|)) + 'T) + (|asyComma?| |op|)) + (PROG (G167885) + (SPADLET G167885 NIL) + (RETURN + (DO ((G167890 |argl| (CDR G167890)) (|x| NIL)) + ((OR (ATOM G167890) + (PROGN (SETQ |x| (CAR G167890)) NIL)) + (NREVERSE0 G167885)) + (SEQ (EXIT (SETQ G167885 + (CONS (|asyConstructorArg| |x|) + G167885)))))))) + ('T (CONS (|asyConstructorArg| |source|) NIL))))))))) + +;asyConstructorArg x == +; x is ['Declare,name,t,:.] => name +; x + +(DEFUN |asyConstructorArg| (|x|) + (PROG (|ISTMP#1| |name| |ISTMP#2| |t|) + (RETURN + (COND + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|Declare|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |name| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN (SPADLET |t| (QCAR |ISTMP#2|)) 'T)))))) + |name|) + ('T |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 + +(DEFUN |asyCosig| (|sig|) + (PROG (|ISTMP#1| |source| |ISTMP#2| |target| |op| |argl|) + (RETURN + (SEQ (COND + ((OR (ATOM |sig|) + (AND (PAIRP |sig|) (EQ (QCAR |sig|) '|With|))) + NIL) + ((AND (PAIRP |sig|) (EQ (QCAR |sig|) '->) + (PROGN + (SPADLET |ISTMP#1| (QCDR |sig|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |source| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |target| (QCAR |ISTMP#2|)) + 'T)))))) + (COND + ((AND (PAIRP |source|) + (PROGN + (SPADLET |op| (QCAR |source|)) + (SPADLET |argl| (QCDR |source|)) + 'T) + (|asyComma?| |op|)) + (PROG (G167955) + (SPADLET G167955 NIL) + (RETURN + (DO ((G167960 |argl| (CDR G167960)) (|x| NIL)) + ((OR (ATOM G167960) + (PROGN (SETQ |x| (CAR G167960)) NIL)) + (NREVERSE0 G167955)) + (SEQ (EXIT (SETQ G167955 + (CONS (|asyCosigType| |x|) + G167955)))))))) + ('T (CONS (|asyCosigType| |source|) NIL)))) + ('T (|error| NIL))))))) + +;asyCosigType u == +; u is [name,t] => +; t is [fn,:.] => +; asyComma? fn => fn +; fn = 'With => 'T +; nil +; t = 'Type => 'T +; error '"Unknown atomic type" +; error false + +(DEFUN |asyCosigType| (|u|) + (PROG (|name| |ISTMP#1| |t| |fn|) + (RETURN + (COND + ((AND (PAIRP |u|) + (PROGN + (SPADLET |name| (QCAR |u|)) + (SPADLET |ISTMP#1| (QCDR |u|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |t| (QCAR |ISTMP#1|)) 'T)))) + (COND + ((AND (PAIRP |t|) (PROGN (SPADLET |fn| (QCAR |t|)) 'T)) + (COND + ((|asyComma?| |fn|) |fn|) + ((BOOT-EQUAL |fn| '|With|) 'T) + ('T NIL))) + ((BOOT-EQUAL |t| '|Type|) 'T) + ('T (|error| (MAKESTRING "Unknown atomic type"))))) + ('T (|error| NIL)))))) + +;asyAbbreviation(id,n) == chk(id,main) where --> n = number of arguments +; main == +; a := createAbbreviation id => a +; name := PNAME id +;-- #name < 8 => INTERN UPCASE name +; parts := asySplit(name,MAXINDEX name) +; newname := "STRCONC"/[asyShorten x for x in parts] +; #newname < 8 => INTERN newname +; tryname := SUBSTRING(name,0,7) +; not createAbbreviation tryname => INTERN UPCASE tryname +; nil +; chk(conname,abb) == +; (xx := asyGetAbbrevFromComments conname) => xx +; con := abbreviation? abb => +; conname = con => abb +; conname +; abb + +(DEFUN |asyAbbreviation,chk| (|conname| |abb|) + (PROG (|xx| |con|) + (RETURN + (SEQ (IF (SPADLET |xx| (|asyGetAbbrevFromComments| |conname|)) + (EXIT |xx|)) + (IF (SPADLET |con| (|abbreviation?| |abb|)) + (EXIT (SEQ (IF (BOOT-EQUAL |conname| |con|) + (EXIT |abb|)) + (EXIT |conname|)))) + (EXIT |abb|))))) + +(DEFUN |asyAbbreviation| (|id| |n|) + (declare (ignore |n|)) + (PROG (|a| |name| |parts| |newname| |tryname|) + (RETURN + (SEQ (|asyAbbreviation,chk| |id| + (COND + ((SPADLET |a| (|createAbbreviation| |id|)) |a|) + ('T (SPADLET |name| (PNAME |id|)) + (SPADLET |parts| + (|asySplit| |name| (MAXINDEX |name|))) + (SPADLET |newname| + (PROG (G168004) + (SPADLET G168004 "") + (RETURN + (DO ((G168009 |parts| (CDR G168009)) + (|x| NIL)) + ((OR (ATOM G168009) + (PROGN + (SETQ |x| (CAR G168009)) + NIL)) + G168004) + (SEQ (EXIT + (SETQ G168004 + (STRCONC G168004 + (|asyShorten| |x|))))))))) + (COND + ((QSLESSP (|#| |newname|) 8) (INTERN |newname|)) + ('T (SPADLET |tryname| (SUBSTRING |name| 0 7)) + (COND + ((NULL (|createAbbreviation| |tryname|)) + (INTERN (UPCASE |tryname|))) + ('T NIL))))))))))) + +;asyGetAbbrevFromComments con == +; docHash := HGET($docHash,con) +; u := [[op,:[fn(x,op) for x in rec]] for op in HKEYS docHash +; | rec := HGET(docHash,op)] where fn(x,op) == +; [form,sig,pred,origin,where?,comments,:.] := x +; ----------> Constants change <-------------- +; if IDENTP sig then sig := [sig] +; [asySignature(sig,nil),trimComments comments] +; [form,sig,pred,origin,where?,comments] := first HGET($conHash,con) +; --above "first" assumes only one entry +; x := asyExtractAbbreviation comments +; x => intern x +; NIL + +(DEFUN |asyGetAbbrevFromComments,fn| (|x| |op|) + (declare (ignore |op|)) + (PROG (|form| |pred| |origin| |where?| |comments| |sig|) + (RETURN + (SEQ (PROGN + (SPADLET |form| (CAR |x|)) + (SPADLET |sig| (CADR |x|)) + (SPADLET |pred| (CADDR |x|)) + (SPADLET |origin| (CADDDR |x|)) + (SPADLET |where?| (CAR (CDDDDR |x|))) + (SPADLET |comments| (CADR (CDDDDR |x|))) + |x|) + (IF (IDENTP |sig|) (SPADLET |sig| (CONS |sig| NIL)) NIL) + (EXIT (CONS (|asySignature| |sig| NIL) + (CONS (|trimComments| |comments|) NIL))))))) + +(DEFUN |asyGetAbbrevFromComments| (|con|) + (PROG (|docHash| |rec| |u| |LETTMP#1| |form| |sig| |pred| |origin| + |where?| |comments| |x|) + (declare (special |$conHash| |$docHash|)) + (RETURN + (SEQ (PROGN + (SPADLET |docHash| (HGET |$docHash| |con|)) + (SPADLET |u| + (PROG (G168064) + (SPADLET G168064 NIL) + (RETURN + (DO ((G168070 (HKEYS |docHash|) + (CDR G168070)) + (|op| NIL)) + ((OR (ATOM G168070) + (PROGN + (SETQ |op| (CAR G168070)) + NIL)) + (NREVERSE0 G168064)) + (SEQ (EXIT (COND + ((SPADLET |rec| + (HGET |docHash| |op|)) + (SETQ G168064 + (CONS + (CONS |op| + (PROG (G168080) + (SPADLET G168080 NIL) + (RETURN + (DO + ((G168085 |rec| + (CDR G168085)) + (|x| NIL)) + ((OR (ATOM G168085) + (PROGN + (SETQ |x| + (CAR G168085)) + NIL)) + (NREVERSE0 + G168080)) + (SEQ + (EXIT + (SETQ G168080 + (CONS + (|asyGetAbbrevFromComments,fn| + |x| |op|) + G168080)))))))) + G168064)))))))))) + (SPADLET |LETTMP#1| (CAR (HGET |$conHash| |con|))) + (SPADLET |form| (CAR |LETTMP#1|)) + (SPADLET |sig| (CADR |LETTMP#1|)) + (SPADLET |pred| (CADDR |LETTMP#1|)) + (SPADLET |origin| (CADDDR |LETTMP#1|)) + (SPADLET |where?| (CAR (CDDDDR |LETTMP#1|))) + (SPADLET |comments| (CADR (CDDDDR |LETTMP#1|))) + (SPADLET |x| (|asyExtractAbbreviation| |comments|)) + (COND (|x| (|intern| |x|)) ('T NIL))))))) + +;asyExtractAbbreviation str == +; not (k:= STRPOS('"Abbrev: ",str,0,nil)) => NIL +; str := SUBSTRING(str, k+8, nil) +; k := STRPOS($stringNewline, str,0,nil) +; k => SUBSTRING(str, 0, k) +; str + +(DEFUN |asyExtractAbbreviation| (|str|) + (PROG (|k|) + (declare (special |$stringNewline|)) + (RETURN + (COND + ((NULL (SPADLET |k| + (STRPOS (MAKESTRING "Abbrev: ") |str| 0 NIL))) + NIL) + ('T (SPADLET |str| (SUBSTRING |str| (PLUS |k| 8) NIL)) + (SPADLET |k| (STRPOS |$stringNewline| |str| 0 NIL)) + (COND (|k| (SUBSTRING |str| 0 |k|)) ('T |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 + +(DEFUN |asyShorten| (|x|) + (PROG (|y|) + (RETURN + (COND + ((SPADLET |y| + (OR (|createAbbreviation| |x|) + (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|) + ('T (UPCASE |x|)))))) + +;asySplit(name,end) == +; end < 1 => [name] +; k := 0 +; for i in 1..end while LOWER_-CASE_-P name.i repeat k := i +; k := k + 1 +; [SUBSTRING(name,0,k),:asySplit(SUBSTRING(name,k,nil),end-k)] + +(DEFUN |asySplit| (|name| |end|) + (PROG (|k|) + (RETURN + (SEQ (COND + ((> 1 |end|) (CONS |name| NIL)) + ('T (SPADLET |k| 0) + (DO ((|i| 1 (QSADD1 |i|))) + ((OR (QSGREATERP |i| |end|) + (NULL (LOWER-CASE-P (ELT |name| |i|)))) + NIL) + (SEQ (EXIT (SPADLET |k| |i|)))) + (SPADLET |k| (PLUS |k| 1)) + (CONS (SUBSTRING |name| 0 |k|) + (|asySplit| (SUBSTRING |name| |k| NIL) + (SPADDIFFERENCE |end| |k|))))))))) + +;createAbbreviation s == +; if STRINGP s then s := INTERN s +; a := constructor? s +; a ^= s => a +; nil + +(DEFUN |createAbbreviation| (|s|) + (PROG (|a|) + (RETURN + (PROGN + (COND ((STRINGP |s|) (SPADLET |s| (INTERN |s|)))) + (SPADLET |a| (|constructor?| |s|)) + (COND ((NEQUAL |a| |s|) |a|) ('T NIL)))))) + +;--============================================================================ +;-- extending getConstructorModemap Property +;--============================================================================ +;--Note: modemap property is built when getConstructorModemap is called +;asyConstructorModemap con == +; HGET($conHash,con) isnt [record,:.] => nil --not there +; [form,sig,predlist,kind,exposure,comments,typeCode,:filename] := record +; $kind: local := kind +; --NOTE: sig has the form (-> source target) or simply (target) +; $constructorArgs: local := KDR form +; signature := asySignature(sig,false) +; formals := ['_$,:TAKE(#$constructorArgs,$FormalMapVariableList)] +; mm := [[[con,:$constructorArgs],:signature],['T,con]] +; SUBLISLIS(formals,['_%,:$constructorArgs],mm) + +(DEFUN |asyConstructorModemap| (|con|) + (PROG (|$kind| |$constructorArgs| |ISTMP#1| |record| |form| |sig| + |predlist| |kind| |exposure| |comments| |typeCode| + |filename| |signature| |formals| |mm|) + (DECLARE (SPECIAL |$kind| |$constructorArgs| |$FormalMapVariableList| + |$conHash|)) + (RETURN + (COND + ((NULL (PROGN + (SPADLET |ISTMP#1| (HGET |$conHash| |con|)) + (AND (PAIRP |ISTMP#1|) + (PROGN (SPADLET |record| (QCAR |ISTMP#1|)) 'T)))) + NIL) + ('T (SPADLET |form| (CAR |record|)) + (SPADLET |sig| (CADR |record|)) + (SPADLET |predlist| (CADDR |record|)) + (SPADLET |kind| (CADDDR |record|)) + (SPADLET |exposure| (CAR (CDDDDR |record|))) + (SPADLET |comments| (CADR (CDDDDR |record|))) + (SPADLET |typeCode| (CADDR (CDDDDR |record|))) + (SPADLET |filename| (CDDDR (CDDDDR |record|))) + (SPADLET |$kind| |kind|) + (SPADLET |$constructorArgs| (KDR |form|)) + (SPADLET |signature| (|asySignature| |sig| NIL)) + (SPADLET |formals| + (CONS '$ + (TAKE (|#| |$constructorArgs|) + |$FormalMapVariableList|))) + (SPADLET |mm| + (CONS (CONS (CONS |con| |$constructorArgs|) + |signature|) + (CONS (CONS 'T (CONS |con| NIL)) NIL))) + (SUBLISLIS |formals| (CONS '% |$constructorArgs|) |mm|)))))) + +;asySignature(sig,names?) == +; sig is ['Join,:.] => [asySig(sig,nil)] +; sig is ['With,:.] => [asySig(sig,nil)] +; sig is ['_-_>,source,target] => +; target := +; names? => ['dummy,target] +; target +; source is [op,:argl] and asyComma? op => +; [asySigTarget(target,names?),:[asySig(x,names?) for x in argl]] +; [asySigTarget(target,names?),asySig(source,names?)] +; ----------> The following is a hack for constants which are category names<-- +; sig is ['Third,:.] => [asySig(sig,nil)] +; ----------> Constants change <-------------- +; asySig(sig,nil) + +(DEFUN |asySignature| (|sig| |names?|) + (PROG (|ISTMP#1| |source| |ISTMP#2| |target| |op| |argl|) + (RETURN + (SEQ (COND + ((AND (PAIRP |sig|) (EQ (QCAR |sig|) '|Join|)) + (CONS (|asySig| |sig| NIL) NIL)) + ((AND (PAIRP |sig|) (EQ (QCAR |sig|) '|With|)) + (CONS (|asySig| |sig| NIL) NIL)) + ((AND (PAIRP |sig|) (EQ (QCAR |sig|) '->) + (PROGN + (SPADLET |ISTMP#1| (QCDR |sig|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |source| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |target| (QCAR |ISTMP#2|)) + 'T)))))) + (SPADLET |target| + (COND + (|names?| (CONS '|dummy| (CONS |target| NIL))) + ('T |target|))) + (COND + ((AND (PAIRP |source|) + (PROGN + (SPADLET |op| (QCAR |source|)) + (SPADLET |argl| (QCDR |source|)) + 'T) + (|asyComma?| |op|)) + (CONS (|asySigTarget| |target| |names?|) + (PROG (G168202) + (SPADLET G168202 NIL) + (RETURN + (DO ((G168207 |argl| (CDR G168207)) + (|x| NIL)) + ((OR (ATOM G168207) + (PROGN + (SETQ |x| (CAR G168207)) + NIL)) + (NREVERSE0 G168202)) + (SEQ (EXIT (SETQ G168202 + (CONS (|asySig| |x| |names?|) + G168202))))))))) + ('T + (CONS (|asySigTarget| |target| |names?|) + (CONS (|asySig| |source| |names?|) NIL))))) + ((AND (PAIRP |sig|) (EQ (QCAR |sig|) '|Third|)) + (CONS (|asySig| |sig| NIL) NIL)) + ('T (|asySig| |sig| NIL))))))) + +;asySigTarget(u,name?) == asySig1(u,name?,true) + +(DEFUN |asySigTarget| (|u| |name?|) (|asySig1| |u| |name?| 'T)) + +;asySig(u,name?) == asySig1(u,name?,false) + +(DEFUN |asySig| (|u| |name?|) (|asySig1| |u| |name?| NIL)) + +;asySig1(u,name?,target?) == +; x := +; name? and u is [name,t] => t +; u +; x is [fn,:r] => +; fn = 'Join => asyTypeJoin r ---------> jump out to newer code 4/94 +; MEMQ(fn, '(RestrictTo PretendTo)) => asySig(first r,name?) +; asyComma? fn => +; u := [asySig(x,name?) for x in r] +; target? => +; null u => '(Void) +; -- this implies a multiple value return, not currently supported +; -- in the interpreter +; ['Multi,:u] +; u +; fn = 'With => asyCATEGORY r +; fn = 'Third => +; r is [b] => +; b is ['With,:s] => asyCATEGORY s +; b is ['Blank,:.] => asyCATEGORY nil +; error x +; fn = 'Apply and r is ['_-_>,:s] => asyMapping(s,name?) +; fn = '_-_> => asyMapping(r,name?) +; fn = 'Declare and r is [name,typ,:.] => +; asySig1(typ, name?, target?) +; x is '(_%) => '(_$) +; [fn,:[asySig(x,name?) for x in r]] +;--x = 'Type => '(Type) +; x = '_% => '_$ +; x + +(DEFUN |asySig1| (|u| |name?| |target?|) + (PROG (|t| |x| |fn| |r| |b| |s| |name| |ISTMP#1| |typ|) + (RETURN + (SEQ (PROGN + (SPADLET |x| + (COND + ((AND |name?| (PAIRP |u|) + (PROGN + (SPADLET |name| (QCAR |u|)) + (SPADLET |ISTMP#1| (QCDR |u|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |t| (QCAR |ISTMP#1|)) + 'T)))) + |t|) + ('T |u|))) + (COND + ((AND (PAIRP |x|) + (PROGN + (SPADLET |fn| (QCAR |x|)) + (SPADLET |r| (QCDR |x|)) + 'T)) + (COND + ((BOOT-EQUAL |fn| '|Join|) (|asyTypeJoin| |r|)) + ((MEMQ |fn| '(|RestrictTo| |PretendTo|)) + (|asySig| (CAR |r|) |name?|)) + ((|asyComma?| |fn|) + (SPADLET |u| + (PROG (G168262) + (SPADLET G168262 NIL) + (RETURN + (DO ((G168267 |r| (CDR G168267)) + (|x| NIL)) + ((OR (ATOM G168267) + (PROGN + (SETQ |x| (CAR G168267)) + NIL)) + (NREVERSE0 G168262)) + (SEQ (EXIT + (SETQ G168262 + (CONS (|asySig| |x| |name?|) + G168262)))))))) + (COND + (|target?| + (COND + ((NULL |u|) '(|Void|)) + ('T (CONS '|Multi| |u|)))) + ('T |u|))) + ((BOOT-EQUAL |fn| '|With|) (|asyCATEGORY| |r|)) + ((BOOT-EQUAL |fn| '|Third|) + (COND + ((AND (PAIRP |r|) (EQ (QCDR |r|) NIL) + (PROGN (SPADLET |b| (QCAR |r|)) 'T)) + (COND + ((AND (PAIRP |b|) (EQ (QCAR |b|) '|With|) + (PROGN (SPADLET |s| (QCDR |b|)) 'T)) + (|asyCATEGORY| |s|)) + ((AND (PAIRP |b|) (EQ (QCAR |b|) '|Blank|)) + (|asyCATEGORY| NIL)))) + ('T (|error| |x|)))) + ((AND (BOOT-EQUAL |fn| '|Apply|) (PAIRP |r|) + (EQ (QCAR |r|) '->) + (PROGN (SPADLET |s| (QCDR |r|)) 'T)) + (|asyMapping| |s| |name?|)) + ((BOOT-EQUAL |fn| '->) (|asyMapping| |r| |name?|)) + ((AND (BOOT-EQUAL |fn| '|Declare|) (PAIRP |r|) + (PROGN + (SPADLET |name| (QCAR |r|)) + (SPADLET |ISTMP#1| (QCDR |r|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |typ| (QCAR |ISTMP#1|)) + 'T)))) + (|asySig1| |typ| |name?| |target?|)) + ((EQUAL |x| '(%)) '($)) + ('T + (CONS |fn| + (PROG (G168277) + (SPADLET G168277 NIL) + (RETURN + (DO ((G168282 |r| (CDR G168282)) + (|x| NIL)) + ((OR (ATOM G168282) + (PROGN + (SETQ |x| (CAR G168282)) + NIL)) + (NREVERSE0 G168277)) + (SEQ (EXIT + (SETQ G168277 + (CONS (|asySig| |x| |name?|) + G168277))))))))))) + ((BOOT-EQUAL |x| '%) '$) + ('T |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] + +(DEFUN |asyMapping| (G168311 |name?|) + (PROG (|a| |newa| |b| |op| |r| |args|) + (RETURN + (PROGN + (SPADLET |a| (CAR G168311)) + (SPADLET |b| (CADR G168311)) + (SPADLET |newa| (|asySig| |a| |name?|)) + (SPADLET |b| (|asySig| |b| |name?|)) + (SPADLET |args| + (COND + ((AND (PAIRP |a|) + (PROGN + (SPADLET |op| (QCAR |a|)) + (SPADLET |r| (QCDR |a|)) + 'T) + (|asyComma?| |op|)) + |newa|) + ('T (CONS |a| NIL)))) + (CONS '|Mapping| (CONS |b| |args|)))))) + +;--============================================================================ +;-- code for asySignatures of the form (Join,:...) +;--============================================================================ +;asyType x == +; x is [fn,:r] => +; fn = 'Join => asyTypeJoin r +; MEMQ(fn, '(RestrictTo PretendTo)) => asyType first r +; asyComma? fn => +; u := [asyType x for x in r] +; u +; fn = 'With => asyCATEGORY r +; fn = '_-_> => asyTypeMapping r +; fn = 'Apply => r +;-- fn = 'Declare and r is [name,typ,:.] => typ +; x is '(_%) => '(_$) +; x +;--x = 'Type => '(Type) +; x = '_% => '_$ +; x + +(DEFUN |asyType| (|x|) + (PROG (|fn| |r| |u|) + (RETURN + (SEQ (COND + ((AND (PAIRP |x|) + (PROGN + (SPADLET |fn| (QCAR |x|)) + (SPADLET |r| (QCDR |x|)) + 'T)) + (COND + ((BOOT-EQUAL |fn| '|Join|) (|asyTypeJoin| |r|)) + ((MEMQ |fn| '(|RestrictTo| |PretendTo|)) + (|asyType| (CAR |r|))) + ((|asyComma?| |fn|) + (SPADLET |u| + (PROG (G168343) + (SPADLET G168343 NIL) + (RETURN + (DO ((G168348 |r| (CDR G168348)) + (|x| NIL)) + ((OR (ATOM G168348) + (PROGN + (SETQ |x| (CAR G168348)) + NIL)) + (NREVERSE0 G168343)) + (SEQ (EXIT + (SETQ G168343 + (CONS (|asyType| |x|) G168343)))))))) + |u|) + ((BOOT-EQUAL |fn| '|With|) (|asyCATEGORY| |r|)) + ((BOOT-EQUAL |fn| '->) (|asyTypeMapping| |r|)) + ((BOOT-EQUAL |fn| '|Apply|) |r|) + ((EQUAL |x| '(%)) '($)) + ('T |x|))) + ((BOOT-EQUAL |x| '%) '$) + ('T |x|)))))) + +;asyTypeJoin r == +; $conStack : local := nil +; $opStack : local := nil +; $predlist : local := nil +; for x in r repeat asyTypeJoinPart(x,$predlist) +; catpart := +; $opStack => ['CATEGORY,$kind,:asyTypeJoinStack REVERSE $opStack] +; nil +; conpart := asyTypeJoinStack REVERSE $conStack +; conpart => +; catpart => ['Join,:conpart,catpart] +; CDR conpart => ['Join,:conpart] +; conpart +; catpart + +(DEFUN |asyTypeJoin| (|r|) + (PROG (|$conStack| |$opStack| |$predlist| |catpart| |conpart|) + (DECLARE (SPECIAL |$conStack| |$opStack| |$predlist| |$kind|)) + (RETURN + (SEQ (PROGN + (SPADLET |$conStack| NIL) + (SPADLET |$opStack| NIL) + (SPADLET |$predlist| NIL) + (DO ((G168367 |r| (CDR G168367)) (|x| NIL)) + ((OR (ATOM G168367) + (PROGN (SETQ |x| (CAR G168367)) NIL)) + NIL) + (SEQ (EXIT (|asyTypeJoinPart| |x| |$predlist|)))) + (SPADLET |catpart| + (COND + (|$opStack| + (CONS 'CATEGORY + (CONS |$kind| + (|asyTypeJoinStack| + (REVERSE |$opStack|))))) + ('T NIL))) + (SPADLET |conpart| + (|asyTypeJoinStack| (REVERSE |$conStack|))) + (COND + (|conpart| + (COND + (|catpart| + (CONS '|Join| + (APPEND |conpart| (CONS |catpart| NIL)))) + ((CDR |conpart|) (CONS '|Join| |conpart|)) + ('T |conpart|))) + ('T |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 + +(DEFUN |asyTypeJoinPart| (|x| |$predlist|) + (DECLARE (SPECIAL |$predlist|)) + (PROG (|y|) + (RETURN + (SEQ (COND + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|Join|) + (PROGN (SPADLET |y| (QCDR |x|)) 'T)) + (DO ((G168391 |y| (CDR G168391)) (|z| NIL)) + ((OR (ATOM G168391) + (PROGN (SETQ |z| (CAR G168391)) NIL)) + NIL) + (SEQ (EXIT (|asyTypeJoinPart| |z| |$predlist|))))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|With|) + (PROGN (SPADLET |y| (QCDR |x|)) 'T)) + (DO ((G168400 |y| (CDR G168400)) (|p| NIL)) + ((OR (ATOM G168400) + (PROGN (SETQ |p| (CAR G168400)) NIL)) + NIL) + (SEQ (EXIT (|asyTypeJoinPartWith| |p|))))) + ('T (|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 + +(DEFUN |asyTypeJoinPartWith| (|x|) + (PROG (|y| |r|) + (RETURN + (SEQ (COND + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|Exports|) + (PROGN (SPADLET |y| (QCDR |x|)) 'T)) + (DO ((G168416 |y| (CDR G168416)) (|p| NIL)) + ((OR (ATOM G168416) + (PROGN (SETQ |p| (CAR G168416)) NIL)) + NIL) + (SEQ (EXIT (|asyTypeJoinPartExport| |p|))))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|Exports|)) + (|systemError| '|exports|)) + ((AND (PAIRP |x|) (EQ (QCDR |x|) NIL) + (EQ (QCAR |x|) '|Comma|)) + NIL) + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|Export|) + (PROGN (SPADLET |y| (QCDR |x|)) 'T)) + NIL) + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'IF) + (PROGN (SPADLET |r| (QCDR |x|)) 'T)) + (|asyTypeJoinPartIf| |r|)) + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|Sequence|) + (PROGN (SPADLET |x| (QCDR |x|)) 'T)) + (DO ((G168425 |x| (CDR G168425)) (|y| NIL)) + ((OR (ATOM G168425) + (PROGN (SETQ |y| (CAR G168425)) NIL)) + NIL) + (SEQ (EXIT (|asyTypeJoinItem| |y|))))) + ('T (|asyTypeJoinItem| |x|))))))) + +;asyTypeJoinPartIf [pred,value] == +; predlist := [asyTypeJoinPartPred pred,:$predlist] +; asyTypeJoinPart(value,predlist) + +(DEFUN |asyTypeJoinPartIf| (G168439) + (PROG (|pred| |value| |predlist|) + (declare (special |$predlist|)) + (RETURN + (PROGN + (SPADLET |pred| (CAR G168439)) + (SPADLET |value| (CADR G168439)) + (SPADLET |predlist| + (CONS (|asyTypeJoinPartPred| |pred|) |$predlist|)) + (|asyTypeJoinPart| |value| |predlist|))))) + +;asyTypeJoinPartPred x == +; x is ['Test, y] => asyTypeUnit y +; asyTypeUnit x + +(DEFUN |asyTypeJoinPartPred| (|x|) + (PROG (|ISTMP#1| |y|) + (RETURN + (COND + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|Test|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |y| (QCAR |ISTMP#1|)) 'T)))) + (|asyTypeUnit| |y|)) + ('T (|asyTypeUnit| |x|)))))) + +;asyTypeJoinItem x == +; result := asyTypeUnit x +; isLowerCaseLetter (PNAME opOf result).0 => +; $opStack := [[['ATTRIBUTE,result],:$predlist],:$opStack] +; $conStack := [[result,:$predlist],:$conStack] + +(DEFUN |asyTypeJoinItem| (|x|) + (PROG (|result|) + (declare (special |$predlist| |$conStack| |$opStack|)) + (RETURN + (PROGN + (SPADLET |result| (|asyTypeUnit| |x|)) + (COND + ((|isLowerCaseLetter| (ELT (PNAME (|opOf| |result|)) 0)) + (SPADLET |$opStack| + (CONS (CONS (CONS 'ATTRIBUTE (CONS |result| NIL)) + |$predlist|) + |$opStack|))) + ('T + (SPADLET |$conStack| + (CONS (CONS |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] + +(DEFUN |asyTypeMapping| (G168476) + (PROG (|a| |b| |op| |r| |args|) + (RETURN + (PROGN + (SPADLET |a| (CAR G168476)) + (SPADLET |b| (CADR G168476)) + (SPADLET |a| (|asyTypeUnit| |a|)) + (SPADLET |b| (|asyTypeUnit| |b|)) + (SPADLET |args| + (COND + ((AND (PAIRP |a|) + (PROGN + (SPADLET |op| (QCAR |a|)) + (SPADLET |r| (QCDR |a|)) + 'T) + (|asyComma?| |op|)) + |r|) + ('T (CONS |a| NIL)))) + (CONS '|Mapping| (CONS |b| |args|)))))) + +;asyTypeUnit x == +; x is [fn,:r] => +; fn = 'Join => systemError 'Join ----->asyTypeJoin r +; MEMQ(fn, '(RestrictTo PretendTo)) => asyTypeUnit first r +; asyComma? fn => +; u := [asyTypeUnit x for x in r] +; u +; fn = 'With => asyCATEGORY r +; fn = '_-_> => asyTypeMapping r +; fn = 'Apply => asyTypeUnitList r +; fn = 'Declare and r is [name,typ,:.] => asyTypeUnitDeclare(name,typ) +; x is '(_%) => '(_$) +; [fn,:asyTypeUnitList r] +; GET(x,'NILADIC) => [x] +;--x = 'Type => '(Type) +; x = '_% => '_$ +; x + +(DEFUN |asyTypeUnit| (|x|) + (PROG (|fn| |r| |u| |name| |ISTMP#1| |typ|) + (RETURN + (SEQ (COND + ((AND (PAIRP |x|) + (PROGN + (SPADLET |fn| (QCAR |x|)) + (SPADLET |r| (QCDR |x|)) + 'T)) + (COND + ((BOOT-EQUAL |fn| '|Join|) (|systemError| '|Join|)) + ((MEMQ |fn| '(|RestrictTo| |PretendTo|)) + (|asyTypeUnit| (CAR |r|))) + ((|asyComma?| |fn|) + (SPADLET |u| + (PROG (G168517) + (SPADLET G168517 NIL) + (RETURN + (DO ((G168522 |r| (CDR G168522)) + (|x| NIL)) + ((OR (ATOM G168522) + (PROGN + (SETQ |x| (CAR G168522)) + NIL)) + (NREVERSE0 G168517)) + (SEQ (EXIT + (SETQ G168517 + (CONS (|asyTypeUnit| |x|) + G168517)))))))) + |u|) + ((BOOT-EQUAL |fn| '|With|) (|asyCATEGORY| |r|)) + ((BOOT-EQUAL |fn| '->) (|asyTypeMapping| |r|)) + ((BOOT-EQUAL |fn| '|Apply|) (|asyTypeUnitList| |r|)) + ((AND (BOOT-EQUAL |fn| '|Declare|) (PAIRP |r|) + (PROGN + (SPADLET |name| (QCAR |r|)) + (SPADLET |ISTMP#1| (QCDR |r|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |typ| (QCAR |ISTMP#1|)) + 'T)))) + (|asyTypeUnitDeclare| |name| |typ|)) + ((EQUAL |x| '(%)) '($)) + ('T (CONS |fn| (|asyTypeUnitList| |r|))))) + ((GETL |x| 'NILADIC) (CONS |x| NIL)) + ((BOOT-EQUAL |x| '%) '$) + ('T |x|)))))) + +;asyTypeUnitList x == [asyTypeUnit y for y in x] + +(DEFUN |asyTypeUnitList| (|x|) + (PROG () + (RETURN + (SEQ (PROG (G168542) + (SPADLET G168542 NIL) + (RETURN + (DO ((G168547 |x| (CDR G168547)) (|y| NIL)) + ((OR (ATOM G168547) + (PROGN (SETQ |y| (CAR G168547)) NIL)) + (NREVERSE0 G168542)) + (SEQ (EXIT (SETQ G168542 + (CONS (|asyTypeUnit| |y|) G168542))))))))))) + +;asyTypeUnitDeclare(op,typ) == +; typ is ['Apply, :r] => asyCatSignature(op,r) +; asyTypeUnit typ + +(DEFUN |asyTypeUnitDeclare| (|op| |typ|) + (PROG (|r|) + (RETURN + (COND + ((AND (PAIRP |typ|) (EQ (QCAR |typ|) '|Apply|) + (PROGN (SPADLET |r| (QCDR |typ|)) 'T)) + (|asyCatSignature| |op| |r|)) + ('T (|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 + +(DEFUN |asyCATEGORY| (|x|) + (PROG (|join| |s| |id| |y| |exports| |ISTMP#1| |ISTMP#2| |ops| |r| + |operations| |joins| |LETTMP#1| |a| |na| |cats| + |attribs| |exportPart|) + (RETURN + (SEQ (PROGN + (COND + ((AND (PAIRP |x|) + (PROGN + (SPADLET |join| (QCAR |x|)) + (SPADLET |y| (QCDR |x|)) + 'T) + (PAIRP |join|) (EQ (QCAR |join|) '|Apply|) + (PROGN (SPADLET |s| (QCDR |join|)) 'T)) + (SPADLET |exports| |y|) + (SPADLET |joins| + (COND + ((AND (PAIRP |s|) (EQ (QCAR |s|) '|Join|) + (PROGN (SPADLET |r| (QCDR |s|)) 'T)) + (PROG (G168596) + (SPADLET G168596 NIL) + (RETURN + (DO ((G168601 |r| (CDR G168601)) + (|u| NIL)) + ((OR (ATOM G168601) + (PROGN + (SETQ |u| (CAR G168601)) + NIL)) + (NREVERSE0 G168596)) + (SEQ (EXIT + (SETQ G168596 + (CONS (|asyJoinPart| |u|) + G168596)))))))) + ('T (CONS (|asyJoinPart| |s|) NIL))))) + ((AND (PAIRP |x|) + (PROGN + (SPADLET |id| (QCAR |x|)) + (SPADLET |y| (QCDR |x|)) + 'T) + (IDENTP |id|)) + (SPADLET |joins| (CONS (CONS |id| NIL) NIL)) + (SPADLET |exports| |y|)) + ('T (SPADLET |joins| NIL) (SPADLET |exports| |x|))) + (SPADLET |cats| |exports|) + (SPADLET |operations| NIL) + (COND + ((AND (PAIRP |exports|) + (PROGN + (SPADLET |ISTMP#1| (REVERSE |exports|)) + 'T) + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCAR |ISTMP#2|) '|Exports|) + (PROGN + (SPADLET |ops| (QCDR |ISTMP#2|)) + 'T))) + (PROGN (SPADLET |r| (QCDR |ISTMP#1|)) 'T) + (PROGN (SPADLET |r| (NREVERSE |r|)) 'T)) + (SPADLET |cats| |r|) (SPADLET |operations| |ops|))) + (SPADLET |exportPart| + (CONS 'CATEGORY + (CONS '|domain| + (PROG (G168607) + (SPADLET G168607 NIL) + (RETURN + (DO + ((G168612 |operations| + (CDR G168612)) + (|y| NIL)) + ((OR (ATOM G168612) + (PROGN + (SETQ |y| (CAR G168612)) + NIL)) + G168607) + (SEQ + (EXIT + (SETQ G168607 + (APPEND G168607 + (|asyCatItem| |y|))))))))))) + (SPADLET |LETTMP#1| (|asyFindAttrs| |joins|)) + (SPADLET |attribs| (CAR |LETTMP#1|)) + (SPADLET |na| (CADR |LETTMP#1|)) + (SPADLET |joins| |na|) + (SPADLET |cats| + (PROG (G168618) + (SPADLET G168618 NIL) + (RETURN + (DO ((G168623 |cats| (CDR G168623)) + (|c| NIL)) + ((OR (ATOM G168623) + (PROGN + (SETQ |c| (CAR G168623)) + NIL)) + G168618) + (SEQ (EXIT (SETQ G168618 + (APPEND G168618 + (|asyCattran| |c|))))))))) + (SPADLET |LETTMP#1| (|asyFindAttrs| |cats|)) + (SPADLET |a| (CAR |LETTMP#1|)) + (SPADLET |na| (CADR |LETTMP#1|)) + (SPADLET |cats| |na|) + (SPADLET |attribs| (APPEND |attribs| |a|)) + (SPADLET |attribs| + (PROG (G168633) + (SPADLET G168633 NIL) + (RETURN + (DO ((G168638 |attribs| (CDR G168638)) + (|x| NIL)) + ((OR (ATOM G168638) + (PROGN + (SETQ |x| (CAR G168638)) + NIL)) + (NREVERSE0 G168633)) + (SEQ (EXIT (SETQ G168633 + (CONS + (CONS 'ATTRIBUTE + (CONS |x| NIL)) + G168633)))))))) + (SPADLET |exportPart| (APPEND |exportPart| |attribs|)) + (COND + ((OR |joins| |cats| |attribs|) + (CONS '|Join| + (APPEND |joins| + (APPEND |cats| (CONS |exportPart| NIL))))) + ('T |exportPart|))))))) + +;asyFindAttrs l == +; attrs := [] +; notattrs := [] +; for x in l repeat +; x0 := x +; while CONSP x repeat x := CAR x +; if MEMQ(x, _*ATTRIBUTES_*) then attrs := [:attrs, x] +; else notattrs := [:notattrs, x0] +; [attrs, notattrs] + +(DEFUN |asyFindAttrs| (|l|) + (PROG (|x0| |attrs| |notattrs|) + (declare (special *ATTRIBUTES*)) + (RETURN + (SEQ (PROGN + (SPADLET |attrs| NIL) + (SPADLET |notattrs| NIL) + (DO ((G168693 |l| (CDR G168693)) (|x| NIL)) + ((OR (ATOM G168693) + (PROGN (SETQ |x| (CAR G168693)) NIL)) + NIL) + (SEQ (EXIT (PROGN + (SPADLET |x0| |x|) + (DO () ((NULL (CONSP |x|)) NIL) + (SEQ (EXIT (SPADLET |x| (CAR |x|))))) + (COND + ((MEMQ |x| *ATTRIBUTES*) + (SPADLET |attrs| + (APPEND |attrs| (CONS |x| NIL)))) + ('T + (SPADLET |notattrs| + (APPEND |notattrs| + (CONS |x0| NIL))))))))) + (CONS |attrs| (CONS |notattrs| NIL))))))) + +;simpCattran x == +; u := asyCattran x +; u is [y] => y +; ['Join,:u] + +(DEFUN |simpCattran| (|x|) + (PROG (|u| |y|) + (RETURN + (PROGN + (SPADLET |u| (|asyCattran| |x|)) + (COND + ((AND (PAIRP |u|) (EQ (QCDR |u|) NIL) + (PROGN (SPADLET |y| (QCAR |u|)) 'T)) + |y|) + ('T (CONS '|Join| |u|))))))) + +;asyCattran x == +; x is ['With,:r] => "append"/[asyCattran1 x for x in r] +; x is ['IF,:.] => "append"/[asyCattranConstructors(x,nil)] +; [x] + +(DEFUN |asyCattran| (|x|) + (PROG (|r|) + (RETURN + (SEQ (COND + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|With|) + (PROGN (SPADLET |r| (QCDR |x|)) 'T)) + (PROG (G168722) + (SPADLET G168722 NIL) + (RETURN + (DO ((G168727 |r| (CDR G168727)) (|x| NIL)) + ((OR (ATOM G168727) + (PROGN (SETQ |x| (CAR G168727)) NIL)) + G168722) + (SEQ (EXIT (SETQ G168722 + (APPEND G168722 + (|asyCattran1| |x|))))))))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'IF)) + (PROG (G168733) + (SPADLET G168733 NIL) + (RETURN + (DO ((G168738 + (CONS (|asyCattranConstructors| |x| NIL) + NIL) + (CDR G168738)) + (G168720 NIL)) + ((OR (ATOM G168738) + (PROGN + (SETQ G168720 (CAR G168738)) + NIL)) + G168733) + (SEQ (EXIT (SETQ G168733 + (APPEND G168733 G168720)))))))) + ('T (CONS |x| NIL))))))) + +;asyCattran1 x == +; x is ['Exports,:y] => "append"/[asyCattranOp u for u in y] +; x is ['IF,:.] => "append"/[asyCattranConstructors(x,nil)] +; systemError nil + +(DEFUN |asyCattran1| (|x|) + (PROG (|y|) + (RETURN + (SEQ (COND + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|Exports|) + (PROGN (SPADLET |y| (QCDR |x|)) 'T)) + (PROG (G168752) + (SPADLET G168752 NIL) + (RETURN + (DO ((G168757 |y| (CDR G168757)) (|u| NIL)) + ((OR (ATOM G168757) + (PROGN (SETQ |u| (CAR G168757)) NIL)) + G168752) + (SEQ (EXIT (SETQ G168752 + (APPEND G168752 + (|asyCattranOp| |u|))))))))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'IF)) + (PROG (G168763) + (SPADLET G168763 NIL) + (RETURN + (DO ((G168768 + (CONS (|asyCattranConstructors| |x| NIL) + NIL) + (CDR G168768)) + (G168750 NIL)) + ((OR (ATOM G168768) + (PROGN + (SETQ G168750 (CAR G168768)) + NIL)) + G168763) + (SEQ (EXIT (SETQ G168763 + (APPEND G168763 G168750)))))))) + ('T (|systemError| NIL))))))) + +;asyCattranOp [op,:items] == +; "append"/[asyCattranOp1(op,item,nil) for item in items] + +(DEFUN |asyCattranOp| (G168780) + (PROG (|op| |items|) + (RETURN + (SEQ (PROGN + (SPADLET |op| (CAR G168780)) + (SPADLET |items| (CDR G168780)) + (PROG (G168789) + (SPADLET G168789 NIL) + (RETURN + (DO ((G168794 |items| (CDR G168794)) (|item| NIL)) + ((OR (ATOM G168794) + (PROGN (SETQ |item| (CAR G168794)) NIL)) + G168789) + (SEQ (EXIT (SETQ G168789 + (APPEND G168789 + (|asyCattranOp1| |op| |item| NIL))))))))))))) + +;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)] + +(DEFUN |asyCattranOp1| (|op| |item| |predlist|) + (PROG (|p| |ISTMP#2| |x| |ISTMP#1| |t| |pred|) + (RETURN + (SEQ (COND + ((AND (PAIRP |item|) (EQ (QCAR |item|) 'IF) + (PROGN + (SPADLET |ISTMP#1| (QCDR |item|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |p| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |x| (QCAR |ISTMP#2|)) + 'T)))))) + (SPADLET |pred| + (|asyPredTran| + (COND + ((AND (PAIRP |p|) (EQ (QCAR |p|) '|Test|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |p|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |t| (QCAR |ISTMP#1|)) + 'T)))) + |t|) + ('T |p|)))) + (COND + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'IF)) + (PROG (G168829) + (SPADLET G168829 NIL) + (RETURN + (DO ((G168834 |x| (CDR G168834)) (|y| NIL)) + ((OR (ATOM G168834) + (PROGN (SETQ |y| (CAR G168834)) NIL)) + G168829) + (SEQ (EXIT (SETQ G168829 + (APPEND G168829 + (|asyCattranOp1| |op| |y| + (CONS |pred| |predlist|)))))))))) + ('T + (CONS (CONS 'IF + (CONS (|asySimpPred| |pred| |predlist|) + (CONS (|asyCattranSig| |op| |x|) + (CONS '|noBranch| NIL)))) + NIL)))) + ('T (CONS (|asyCattranSig| |op| |item|) NIL))))))) + +;asyPredTran p == asyPredTran1 asyJoinPart p + +(DEFUN |asyPredTran| (|p|) (|asyPredTran1| (|asyJoinPart| |p|))) + +;asyPredTran1 p == +; p is ['Has,x,y] => ['has,x, simpCattran y] +; p is ['Test, q] => asyPredTran1 q +; p is [op,:r] and MEMQ(op,'(AND OR NOT)) => +; [op,:[asyPredTran1 q for q in r]] +; p + +(DEFUN |asyPredTran1| (|p|) + (PROG (|x| |ISTMP#2| |y| |ISTMP#1| |q| |op| |r|) + (RETURN + (SEQ (COND + ((AND (PAIRP |p|) (EQ (QCAR |p|) '|Has|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |p|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |x| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |y| (QCAR |ISTMP#2|)) + 'T)))))) + (CONS '|has| (CONS |x| (CONS (|simpCattran| |y|) NIL)))) + ((AND (PAIRP |p|) (EQ (QCAR |p|) '|Test|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |p|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN (SPADLET |q| (QCAR |ISTMP#1|)) 'T)))) + (|asyPredTran1| |q|)) + ((AND (PAIRP |p|) + (PROGN + (SPADLET |op| (QCAR |p|)) + (SPADLET |r| (QCDR |p|)) + 'T) + (MEMQ |op| '(AND OR NOT))) + (CONS |op| + (PROG (G168882) + (SPADLET G168882 NIL) + (RETURN + (DO ((G168887 |r| (CDR G168887)) (|q| NIL)) + ((OR (ATOM G168887) + (PROGN + (SETQ |q| (CAR G168887)) + NIL)) + (NREVERSE0 G168882)) + (SEQ (EXIT (SETQ G168882 + (CONS (|asyPredTran1| |q|) + G168882))))))))) + ('T |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() + +(DEFUN |asyCattranConstructors| (|item| |predlist|) + (PROG (|p| |ISTMP#2| |x| |ISTMP#1| |t| |pred| |form|) + (RETURN + (SEQ (COND + ((AND (PAIRP |item|) (EQ (QCAR |item|) 'IF) + (PROGN + (SPADLET |ISTMP#1| (QCDR |item|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |p| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |x| (QCAR |ISTMP#2|)) + 'T)))))) + (SPADLET |pred| + (|asyPredTran| + (COND + ((AND (PAIRP |p|) (EQ (QCAR |p|) '|Test|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |p|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |t| (QCAR |ISTMP#1|)) + 'T)))) + |t|) + ('T |p|)))) + (COND + ((AND (PAIRP |x|) (EQ (QCAR |x|) 'IF)) + (PROG (G168929) + (SPADLET G168929 NIL) + (RETURN + (DO ((G168934 + (CONS (|asyCattranConstructors| |x| + (CONS |pred| |predlist|)) + NIL) + (CDR G168934)) + (G168905 NIL)) + ((OR (ATOM G168934) + (PROGN + (SETQ G168905 (CAR G168934)) + NIL)) + G168929) + (SEQ (EXIT (SETQ G168929 + (APPEND G168929 G168905)))))))) + ('T + (SPADLET |form| + (CONS 'ATTRIBUTE + (CONS (|asyJoinPart| |x|) NIL))) + (CONS (CONS 'IF + (CONS (|asySimpPred| |pred| |predlist|) + (CONS |form| (CONS '|noBranch| NIL)))) + NIL)))) + ('T (|systemError|))))))) + +;asySimpPred(p, predlist) == +; while predlist is [q,:predlist] repeat p := quickAnd(q,p) +; p + +(DEFUN |asySimpPred| (|p| |predlist|) + (PROG (|q|) + (RETURN + (SEQ (PROGN + (DO () + ((NULL (AND (PAIRP |predlist|) + (PROGN + (SPADLET |q| (QCAR |predlist|)) + (SPADLET |predlist| (QCDR |predlist|)) + 'T))) + NIL) + (SEQ (EXIT (SPADLET |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]] + +(DEFUN |asyCattranSig| (|op| |y|) + (PROG (|ISTMP#1| |source| |ISTMP#2| |s| |t|) + (RETURN + (SEQ (COND + ((NULL (AND (PAIRP |y|) (EQ (QCAR |y|) '->) + (PROGN + (SPADLET |ISTMP#1| (QCDR |y|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |source| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |t| (QCAR |ISTMP#2|)) + 'T))))))) + (CONS 'SIGNATURE + (CONS |op| + (CONS (CONS (|asyTypeUnit| |y|) NIL) NIL)))) + ('T + (SPADLET |s| + (COND + ((AND (PAIRP |source|) + (EQ (QCAR |source|) '|Comma|) + (PROGN + (SPADLET |s| (QCDR |source|)) + 'T)) + (PROG (G168990) + (SPADLET G168990 NIL) + (RETURN + (DO ((G168995 |s| (CDR G168995)) + (|z| NIL)) + ((OR (ATOM G168995) + (PROGN + (SETQ |z| (CAR G168995)) + NIL)) + (NREVERSE0 G168990)) + (SEQ (EXIT + (SETQ G168990 + (CONS (|asyTypeUnit| |z|) + G168990)))))))) + ('T (CONS (|asyTypeUnit| |source|) NIL)))) + (SPADLET |t| (|asyTypeUnit| |t|)) + (COND + ((NULL |t|) + (CONS 'SIGNATURE (CONS |op| (CONS |s| NIL)))) + ('T + (CONS 'SIGNATURE + (CONS |op| (CONS (CONS |t| |s|) NIL))))))))))) + +;asyJoinPart x == +; IDENTP x => [x] +; asytranForm(x,nil,true) + +(DEFUN |asyJoinPart| (|x|) + (COND ((IDENTP |x|) (CONS |x| NIL)) ('T (|asytranForm| |x| NIL 'T)))) + +;asyCatItem item == +; atom item => [item] +; item is ['IF,.,.] => [item] +; [op,:sigs] := item +; [asyCatSignature(op,sig) for sig in sigs | sig] + +(DEFUN |asyCatItem| (|item|) + (PROG (|ISTMP#1| |ISTMP#2| |op| |sigs|) + (RETURN + (SEQ (COND + ((ATOM |item|) (CONS |item| NIL)) + ((AND (PAIRP |item|) (EQ (QCAR |item|) 'IF) + (PROGN + (SPADLET |ISTMP#1| (QCDR |item|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL)))))) + (CONS |item| NIL)) + ('T (SPADLET |op| (CAR |item|)) + (SPADLET |sigs| (CDR |item|)) + (PROG (G169031) + (SPADLET G169031 NIL) + (RETURN + (DO ((G169037 |sigs| (CDR G169037)) (|sig| NIL)) + ((OR (ATOM G169037) + (PROGN (SETQ |sig| (CAR G169037)) NIL)) + (NREVERSE0 G169031)) + (SEQ (EXIT (COND + (|sig| (SETQ G169031 + (CONS + (|asyCatSignature| |op| + |sig|) + G169031))))))))))))))) + +;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]] + +(DEFUN |asyCatSignature| (|op| |sig|) + (PROG (|ISTMP#1| |source| |ISTMP#2| |target|) + (RETURN + (COND + ((AND (PAIRP |sig|) (EQ (QCAR |sig|) '->) + (PROGN + (SPADLET |ISTMP#1| (QCDR |sig|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |source| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |target| (QCAR |ISTMP#2|)) + 'T)))))) + (CONS 'SIGNATURE + (CONS |op| + (CONS (CONS (|asyTypeItem| |target|) + (|asyUnTuple| |source|)) + NIL)))) + ('T + (CONS 'SIGNATURE + (CONS |op| (CONS (CONS (|asyTypeItem| |sig|) NIL) NIL)))))))) + +;asyUnTuple x == +; x is [op,:u] and asyComma? op => [asyTypeItem y for y in u] +; [asyTypeItem x] + +(DEFUN |asyUnTuple| (|x|) + (PROG (|op| |u|) + (RETURN + (SEQ (COND + ((AND (PAIRP |x|) + (PROGN + (SPADLET |op| (QCAR |x|)) + (SPADLET |u| (QCDR |x|)) + 'T) + (|asyComma?| |op|)) + (PROG (G169083) + (SPADLET G169083 NIL) + (RETURN + (DO ((G169088 |u| (CDR G169088)) (|y| NIL)) + ((OR (ATOM G169088) + (PROGN (SETQ |y| (CAR G169088)) NIL)) + (NREVERSE0 G169083)) + (SEQ (EXIT (SETQ G169083 + (CONS (|asyTypeItem| |y|) + G169083)))))))) + ('T (CONS (|asyTypeItem| |x|) NIL))))))) + +;asyTypeItem x == +; atom x => +; x = '_% => '_$ +; x +; x is ['_-_>,a,b] => +; ['Mapping,b,:asyUnTuple a] +; x is ['Apply,:r] => +; r is ['_-_>,a,b] => +; ['Mapping,b,:asyUnTuple a] +; r is ['Record,:parts] => +; ['Record,:[[":",a,b] for ['Declare,a,b,:.] in parts]] +; r is ['Segment,:parts] => +; ['Segment,:[asyTypeItem x for x in parts]] +; asytranApply(x,nil,true) +; x is ['Declare,.,t,:.] => asyTypeItem t +; x is ['Comma,:args] => +; -- this implies a multiple value return, not currently supported +; -- in the interpreter +; args => ['Multi,:[asyTypeItem y for y in args]] +; ['Void] +; [asyTypeItem y for y in x] + +(DEFUN |asyTypeItem| (|x|) + (PROG (|r| |a| |b| |parts| |ISTMP#1| |ISTMP#2| |t| |args|) + (RETURN + (SEQ (COND + ((ATOM |x|) (COND ((BOOT-EQUAL |x| '%) '$) ('T |x|))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) '->) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |b| (QCAR |ISTMP#2|)) + 'T)))))) + (CONS '|Mapping| (CONS |b| (|asyUnTuple| |a|)))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|Apply|) + (PROGN (SPADLET |r| (QCDR |x|)) 'T)) + (COND + ((AND (PAIRP |r|) (EQ (QCAR |r|) '->) + (PROGN + (SPADLET |ISTMP#1| (QCDR |r|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |b| (QCAR |ISTMP#2|)) + 'T)))))) + (CONS '|Mapping| (CONS |b| (|asyUnTuple| |a|)))) + ((AND (PAIRP |r|) (EQ (QCAR |r|) '|Record|) + (PROGN (SPADLET |parts| (QCDR |r|)) 'T)) + (CONS '|Record| + (PROG (G169155) + (SPADLET G169155 NIL) + (RETURN + (DO ((G169161 |parts| (CDR G169161)) + (G169133 NIL)) + ((OR (ATOM G169161) + (PROGN + (SETQ G169133 (CAR G169161)) + NIL) + (PROGN + (PROGN + (SPADLET |a| (CADR G169133)) + (SPADLET |b| (CADDR G169133)) + G169133) + NIL)) + (NREVERSE0 G169155)) + (SEQ (EXIT (SETQ G169155 + (CONS + (CONS '|:| + (CONS |a| (CONS |b| NIL))) + G169155))))))))) + ((AND (PAIRP |r|) (EQ (QCAR |r|) '|Segment|) + (PROGN (SPADLET |parts| (QCDR |r|)) 'T)) + (CONS '|Segment| + (PROG (G169172) + (SPADLET G169172 NIL) + (RETURN + (DO ((G169177 |parts| (CDR G169177)) + (|x| NIL)) + ((OR (ATOM G169177) + (PROGN + (SETQ |x| (CAR G169177)) + NIL)) + (NREVERSE0 G169172)) + (SEQ (EXIT (SETQ G169172 + (CONS (|asyTypeItem| |x|) + G169172))))))))) + ('T (|asytranApply| |x| NIL 'T)))) + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|Declare|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |t| (QCAR |ISTMP#2|)) + 'T)))))) + (|asyTypeItem| |t|)) + ((AND (PAIRP |x|) (EQ (QCAR |x|) '|Comma|) + (PROGN (SPADLET |args| (QCDR |x|)) 'T)) + (COND + (|args| (CONS '|Multi| + (PROG (G169187) + (SPADLET G169187 NIL) + (RETURN + (DO ((G169192 |args| + (CDR G169192)) + (|y| NIL)) + ((OR (ATOM G169192) + (PROGN + (SETQ |y| (CAR G169192)) + NIL)) + (NREVERSE0 G169187)) + (SEQ + (EXIT + (SETQ G169187 + (CONS (|asyTypeItem| |y|) + G169187))))))))) + ('T (CONS '|Void| NIL)))) + ('T + (PROG (G169202) + (SPADLET G169202 NIL) + (RETURN + (DO ((G169207 |x| (CDR G169207)) (|y| NIL)) + ((OR (ATOM G169207) + (PROGN (SETQ |y| (CAR G169207)) NIL)) + (NREVERSE0 G169202)) + (SEQ (EXIT (SETQ G169202 + (CONS (|asyTypeItem| |y|) + G169202))))))))))))) + +;--============================================================================ +;-- Utilities +;--============================================================================ +;asyComma? op == MEMQ(op,'(Comma Multi)) + +(DEFUN |asyComma?| (|op|) (MEMQ |op| '(|Comma| |Multi|))) + +;hput(table,name,value) == +; if null name then systemError() +; HPUT(table,name,value) + +(DEFUN |hput| (|table| |name| |value|) + (PROGN + (COND ((NULL |name|) (|systemError|))) + (HPUT |table| |name| |value|))) + +;--============================================================================ +;-- category parts +;--============================================================================ +;-- this constructs operation information from a category. +;-- NB: This is categoryParts, but with the kind supplied by +;-- an arguments +;asCategoryParts(kind,conform,category,:options) == main where +; main == +; cons? := IFCAR options --means to include constructors as well +; $attrlist: local := nil +; $oplist : local := nil +; $conslist: local := nil +; conname := opOf conform +; for x in exportsOf(category) repeat build(x,true) +; $attrlist := listSort(function GLESSEQP,$attrlist) +; $oplist := listSort(function GLESSEQP,$oplist) +; res := [$attrlist,:$oplist] +; if cons? then res := [listSort(function GLESSEQP,$conslist),:res] +; if kind = 'category then +; tvl := TAKE(#rest conform,$TriangleVariableList) +; res := SUBLISLIS($FormalMapVariableList,tvl,res) +; res +; build(item,pred) == +; item is ['SIGNATURE,op,sig,:.] => $oplist := [[opOf op,sig,:pred],:$oplist] +; --note: opOf is needed!!! Bug in compiler puts in (One) and (Zero) +; item is ['ATTRIBUTE,attr] => +; constructor? opOf attr => +; $conslist := [[attr,:pred],:$conslist] +; nil +; opOf attr = 'nothing => 'skip +; $attrlist := [[opOf attr,IFCDR attr,:pred],:$attrlist] +; item is ['TYPE,op,type] => +; $oplist := [[op,[type],:pred],:$oplist] +; item is ['IF,pred1,s1,s2] => +; build(s1,quickAnd(pred,pred1)) +; s2 => build(s2,quickAnd(pred,['NOT,pred1])) +; item is ['PROGN,:r] => for x in r repeat build(x,pred) +; item in '(noBranch) => 'ok +; null item => 'ok +; systemError '"build error" +; exportsOf(target) == +; target is ['CATEGORY,.,:r] => r +; target is ['Join,:r,f] => +; for x in r repeat $conslist := [[x,:true],:$conslist] +; exportsOf f +; $conslist := [[target,:true],:$conslist] +; nil + +(DEFUN |asCategoryParts,exportsOf| (|target|) + (PROG (|ISTMP#1| |ISTMP#2| |f| |r|) + (declare (special |$conslist|)) + (RETURN + (SEQ (IF (AND (PAIRP |target|) (EQ (QCAR |target|) 'CATEGORY) + (PROGN + (SPADLET |ISTMP#1| (QCDR |target|)) + (AND (PAIRP |ISTMP#1|) + (PROGN (SPADLET |r| (QCDR |ISTMP#1|)) 'T)))) + (EXIT |r|)) + (IF (AND (PAIRP |target|) (EQ (QCAR |target|) '|Join|) + (PROGN + (SPADLET |ISTMP#1| (QCDR |target|)) + (AND (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| + (REVERSE |ISTMP#1|)) + 'T)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |f| (QCAR |ISTMP#2|)) + (SPADLET |r| (QCDR |ISTMP#2|)) + 'T)) + (PROGN (SPADLET |r| (NREVERSE |r|)) 'T)))) + (EXIT (SEQ (DO ((G169341 |r| (CDR G169341)) + (|x| NIL)) + ((OR (ATOM G169341) + (PROGN + (SETQ |x| (CAR G169341)) + NIL)) + NIL) + (SEQ (EXIT (SPADLET |$conslist| + (CONS (CONS |x| 'T) + |$conslist|))))) + (EXIT (|asCategoryParts,exportsOf| |f|))))) + (SPADLET |$conslist| (CONS (CONS |target| 'T) |$conslist|)) + (EXIT NIL))))) + +(DEFUN |asCategoryParts,build| (|item| |pred|) + (PROG (|sig| |attr| |op| |type| |ISTMP#1| |pred1| |ISTMP#2| |s1| + |ISTMP#3| |s2| |r|) + (declare (special |$oplist| |$attrlist| |$conslist|)) + (RETURN + (SEQ (IF (AND (PAIRP |item|) (EQ (QCAR |item|) 'SIGNATURE) + (PROGN + (SPADLET |ISTMP#1| (QCDR |item|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |op| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |sig| (QCAR |ISTMP#2|)) + 'T)))))) + (EXIT (SPADLET |$oplist| + (CONS (CONS (|opOf| |op|) + (CONS |sig| |pred|)) + |$oplist|)))) + (IF (AND (PAIRP |item|) (EQ (QCAR |item|) 'ATTRIBUTE) + (PROGN + (SPADLET |ISTMP#1| (QCDR |item|)) + (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) + (PROGN + (SPADLET |attr| (QCAR |ISTMP#1|)) + 'T)))) + (EXIT (SEQ (IF (|constructor?| (|opOf| |attr|)) + (EXIT (SEQ + (SPADLET |$conslist| + (CONS (CONS |attr| |pred|) + |$conslist|)) + (EXIT NIL)))) + (IF (BOOT-EQUAL (|opOf| |attr|) '|nothing|) + (EXIT '|skip|)) + (EXIT (SPADLET |$attrlist| + (CONS + (CONS (|opOf| |attr|) + (CONS (IFCDR |attr|) |pred|)) + |$attrlist|)))))) + (IF (AND (PAIRP |item|) (EQ (QCAR |item|) 'TYPE) + (PROGN + (SPADLET |ISTMP#1| (QCDR |item|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |op| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |type| (QCAR |ISTMP#2|)) + 'T)))))) + (EXIT (SPADLET |$oplist| + (CONS (CONS |op| + (CONS (CONS |type| NIL) |pred|)) + |$oplist|)))) + (IF (AND (PAIRP |item|) (EQ (QCAR |item|) 'IF) + (PROGN + (SPADLET |ISTMP#1| (QCDR |item|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |pred1| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |s1| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| + (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET |s2| (QCAR |ISTMP#3|)) + 'T)))))))) + (EXIT (SEQ (|asCategoryParts,build| |s1| + (|quickAnd| |pred| |pred1|)) + (EXIT (IF |s2| + (EXIT + (|asCategoryParts,build| |s2| + (|quickAnd| |pred| + (CONS 'NOT (CONS |pred1| NIL)))))))))) + (IF (AND (PAIRP |item|) (EQ (QCAR |item|) 'PROGN) + (PROGN (SPADLET |r| (QCDR |item|)) 'T)) + (EXIT (DO ((G169362 |r| (CDR G169362)) (|x| NIL)) + ((OR (ATOM G169362) + (PROGN (SETQ |x| (CAR G169362)) NIL)) + NIL) + (SEQ (EXIT (|asCategoryParts,build| |x| |pred|)))))) + (IF (|member| |item| '(|noBranch|)) (EXIT '|ok|)) + (IF (NULL |item|) (EXIT '|ok|)) + (EXIT (|systemError| (MAKESTRING "build error"))))))) + +(DEFUN |asCategoryParts| + (&REST G169422 &AUX |options| |category| |conform| |kind|) + (DSETQ (|kind| |conform| |category| . |options|) G169422) + (PROG (|$attrlist| |$oplist| |$conslist| |cons?| |conname| |tvl| |res|) + (DECLARE (SPECIAL |$attrlist| |$oplist| |$conslist| + |$FormalMapVariableList| |$TriangleVariableList|)) + (RETURN + (SEQ (PROGN + (SPADLET |cons?| (IFCAR |options|)) + (SPADLET |$attrlist| NIL) + (SPADLET |$oplist| NIL) + (SPADLET |$conslist| NIL) + (SPADLET |conname| (|opOf| |conform|)) + (DO ((G169396 (|asCategoryParts,exportsOf| |category|) + (CDR G169396)) + (|x| NIL)) + ((OR (ATOM G169396) + (PROGN (SETQ |x| (CAR G169396)) NIL)) + NIL) + (SEQ (EXIT (|asCategoryParts,build| |x| 'T)))) + (SPADLET |$attrlist| + (|listSort| (|function| GLESSEQP) |$attrlist|)) + (SPADLET |$oplist| + (|listSort| (|function| GLESSEQP) |$oplist|)) + (SPADLET |res| (CONS |$attrlist| |$oplist|)) + (COND + (|cons?| (SPADLET |res| + (CONS (|listSort| + (|function| GLESSEQP) + |$conslist|) + |res|)))) + (COND + ((BOOT-EQUAL |kind| '|category|) + (SPADLET |tvl| + (TAKE (|#| (CDR |conform|)) + |$TriangleVariableList|)) + (SPADLET |res| + (SUBLISLIS |$FormalMapVariableList| |tvl| + |res|)))) + |res|))))) + +;--============================================================================ +;-- 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] + +(DEFUN |asyTypeJoinPartExport| (|x|) + (PROG (|op| |items| |ISTMP#1| |source| |ISTMP#2| |s| |t| |sig|) + (declare (special |$opStack| |$predlist|)) + (RETURN + (SEQ (PROGN + (SPADLET |op| (CAR |x|)) + (SPADLET |items| (CDR |x|)) + (DO ((G169459 |items| (CDR G169459)) (|y| NIL)) + ((OR (ATOM G169459) + (PROGN (SETQ |y| (CAR G169459)) NIL)) + NIL) + (SEQ (EXIT (COND + ((NULL (AND (PAIRP |y|) (EQ (QCAR |y|) '->) + (PROGN + (SPADLET |ISTMP#1| (QCDR |y|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |source| + (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| + (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |t| + (QCAR |ISTMP#2|)) + 'T))))))) + (SPADLET |sig| + (CONS 'SIGNATURE + (CONS |op| + (CONS + (CONS (|asyTypeUnit| |y|) NIL) + NIL)))) + (SPADLET |$opStack| + (CONS (CONS |sig| |$predlist|) + |$opStack|))) + ('T + (SPADLET |s| + (COND + ((AND (PAIRP |source|) + (EQ (QCAR |source|) '|Comma|) + (PROGN + (SPADLET |s| + (QCDR |source|)) + 'T)) + (PROG (G169469) + (SPADLET G169469 NIL) + (RETURN + (DO + ((G169474 |s| + (CDR G169474)) + (|z| NIL)) + ((OR (ATOM G169474) + (PROGN + (SETQ |z| + (CAR G169474)) + NIL)) + (NREVERSE0 G169469)) + (SEQ + (EXIT + (SETQ G169469 + (CONS + (|asyTypeUnit| |z|) + G169469)))))))) + ('T + (CONS (|asyTypeUnit| |source|) + NIL)))) + (SPADLET |t| (|asyTypeUnit| |t|)) + (SPADLET |sig| + (COND + ((NULL |t|) + (CONS 'SIGNATURE + (CONS |op| (CONS |s| NIL)))) + ('T + (CONS 'SIGNATURE + (CONS |op| + (CONS (CONS |t| |s|) NIL)))))) + (SPADLET |$opStack| + (CONS (CONS |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 + +(DEFUN |asyTypeJoinStack| (|r|) + (PROG (|ISTMP#1| |x| |q| |s| |al| |y| |p| |result|) + (RETURN + (SEQ (PROGN + (SPADLET |al| + (PROG (G169533) + (SPADLET G169533 NIL) + (RETURN + (DO () + ((NULL (AND (PAIRP |r|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |r|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |p| + (QCDR |ISTMP#1|)) + 'T))))) + (NREVERSE0 G169533)) + (SEQ (EXIT (SETQ G169533 + (CONS + (CONS + (PROG (G169554) + (SPADLET G169554 NIL) + (RETURN + (DO () + ((NULL + (AND (PAIRP |r|) + (PROGN + (SPADLET |ISTMP#1| + (QCAR |r|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |x| + (QCAR + |ISTMP#1|)) + (SPADLET |q| + (QCDR + |ISTMP#1|)) + 'T))) + (PROGN + (SPADLET |s| + (QCDR |r|)) + 'T) + (BOOT-EQUAL |p| |q|) + (PROGN + (SPADLET |r| |s|) + 'T))) + (NREVERSE0 G169554)) + (SEQ + (EXIT + (SETQ G169554 + (CONS |x| G169554))))))) + |p|) + G169533)))))))) + (SPADLET |result| + (PROG (G169562) + (SPADLET G169562 NIL) + (RETURN + (DO ((G169568 |al| (CDR G169568)) + (G169511 NIL)) + ((OR (ATOM G169568) + (PROGN + (SETQ G169511 (CAR G169568)) + NIL) + (PROGN + (PROGN + (SPADLET |y| (CAR G169511)) + (SPADLET |p| (CDR G169511)) + G169511) + NIL)) + G169562) + (SEQ (EXIT (SETQ G169562 + (APPEND G169562 + (COND + (|p| + (CONS + (CONS 'IF + (CONS + (|asyTypeMakePred| |p|) + |y|)) + NIL)) + ('T |y|)))))))))) + |result|))))) + +;asyTypeMakePred [p,:u] == +; while u is [q,:u] repeat p := quickAnd(q,p) +; p + +(DEFUN |asyTypeMakePred| (G169596) + (PROG (|q| |u| |p|) + (RETURN + (SEQ (PROGN + (SPADLET |p| (CAR G169596)) + (SPADLET |u| (CDR G169596)) + (DO () + ((NULL (AND (PAIRP |u|) + (PROGN + (SPADLET |q| (QCAR |u|)) + (SPADLET |u| (QCDR |u|)) + 'T))) + NIL) + (SEQ (EXIT (SPADLET |p| (|quickAnd| |q| |p|))))) + |p|))))) + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document}