diff --git a/books/bookvol5.pamphlet b/books/bookvol5.pamphlet index 45d9a53..81777cf 100644 --- a/books/bookvol5.pamphlet +++ b/books/bookvol5.pamphlet @@ -36243,10 +36243,6 @@ The localdatabase function tries to find files in the order of: \end{itemize} \calls{localdatabase}{sayKeyedMsg} \calls{localdatabase}{localnrlib} -\calls{localdatabase}{localasy} -\calls{localdatabase}{asharp} -\calls{localdatabase}{astran} -\calls{localdatabase}{localasy} \usesdollar{localdatabase}{forceDatabaseUpdate} \usesdollar{localdatabase}{ConstructorCache} \uses{localdatabase}{*index-filename*} diff --git a/changelog b/changelog index b5f1e9a..5c4e354 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,8 @@ +20110803 tpd src/axiom-website/patches.html 20110803.01.tpd.patch +20110803 tpd books/bookvol5 remove as.lisp +20110803 tpd src/interp/Makefile remove as.lisp +20110803 tpd src/interp/as.lisp removed +20110803 tpd src/interp/br-con.lisp remove reference to as.lisp function 20110802 tpd src/axiom-website/patches.html 20110802.01.tpd.patch 20110802 tpd src/interp/i-funsel.lisp pick up functions from database.lisp 20110802 tpd src/interp/i-analy.lisp pick up functions from database.lisp diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 249ea2b..f3d07e0 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -3571,6 +3571,8 @@ books/bookvol9 treeshake compiler
20110801.01.tpd.patch books/bookvol9 treeshake compiler
20110802.01.tpd.patch -src/interp/database.lisp removed +src/interp/database.lisp removed
+20110803.01.tpd.patch +src/interp/as.lisp removed
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index ef24b0f..fa7e5aa 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -249,8 +249,7 @@ NAGBROBJS= ${AUTO}/nag-c02.${O} ${AUTO}/nag-c05.${O} \ The {\bf ASCOMP} list contains files used by the {\bf Aldor} \cite{5} compiler. These files should probably be autoloaded. <>= -ASCOMP= ${OUT}/hashcode.${O} ${OUT}/as.${O} \ - ${OUT}/foam_l.${O} +ASCOMP= ${OUT}/hashcode.${O} ${OUT}/foam_l.${O} @ The {\bf ASAUTO} list contains files used by the {\bf Aldor} @@ -2829,30 +2828,6 @@ ${MID}/termrw.lisp: ${IN}/termrw.lisp.pamphlet @ -\subsection{as.lisp} -<>= -${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.lisp"' \ - ':output-file "${OUT}/as.${O}") (${BYE}))' | ${DEPSYS} ; \ - else \ - echo '(progn (compile-file "${MID}/as.lisp"' \ - ':output-file "${OUT}/as.${O}") (${BYE}))' | ${DEPSYS} \ - >${TMP}/trace ; \ - fi ) - -@ -<>= -${MID}/as.lisp: ${IN}/as.lisp.pamphlet - @ echo 137 making ${MID}/as.lisp from ${IN}/as.lisp.pamphlet - @ (cd ${MID} ; \ - echo '(tangle "${IN}/as.lisp.pamphlet" "*" "as.lisp")' \ - | ${OBJ}/${SYS}/bin/lisp ) - -@ - \subsection{bc-matrix.lisp} <>= ${AUTO}/bc-matrix.${O}: ${OUT}/bc-matrix.${O} @@ -3275,9 +3250,6 @@ clean: <> <> -<> -<> - <> <> <> diff --git a/src/interp/as.lisp.pamphlet b/src/interp/as.lisp.pamphlet deleted file mode 100644 index 1698c87..0000000 --- a/src/interp/as.lisp.pamphlet +++ /dev/null @@ -1,4809 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp as.lisp} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\begin{chunk}{*} -(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 "rm -f temp.text") - (OBEY "ls as/*.asy > temp.text") - (SPADLET |instream| (OPEN "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 "-----> " - (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|) ".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|) - ".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|)) - ".as")) - (SPADLET |constantPart| - (AND (HGET |$constantHash| |con|) - (CONS (CONS '|constant| 'T) NIL))) - (SPADLET |niladicPart| - (AND (member |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 "----------------- " - (CONS |y| - (CONS " --------------------" 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| - "==============================") - (|sayBrightly| - (CONS |banner| - (CONS " " - (CONS |con| - (CONS " " - (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 ": " 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 - ((member |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 - ((member |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 "Description:" |str| 0 NIL)) - (|asyExtractDescription| (SUBSTRING |str| (PLUS |k| 12) NIL))) - ((SPADLET |k| (STRPOS "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| "")) - "") - ('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))) - (member |op| '(|PretendTo| |RestrictTo|))) - (|asyAncestors| |y|)) - ((ATOM |x|) - (COND - ((BOOT-EQUAL |x| '%) '$) - ((member |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 " 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| "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|) "")) - (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 - ((member |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))))) - (member |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| "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 - ((member |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| "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| "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?|)))) - ((member (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| "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 "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|)) - ((member |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|)) - ((member |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|)) - ((member |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 - ((member |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) - (member |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|) (member |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| "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|))))) - -\end{chunk} -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/br-con.lisp.pamphlet b/src/interp/br-con.lisp.pamphlet index ca24050..4329cb0 100644 --- a/src/interp/br-con.lisp.pamphlet +++ b/src/interp/br-con.lisp.pamphlet @@ -23366,9 +23366,6 @@ $dbKindAlist := ((NULL (|isExposedConstructor| |conname|)) (SPADLET |heading| (CONS "Unexposed " |heading|)))) - (COND - ((BOOT-EQUAL |name| |abbrev|) - (SPADLET |abbrev| (|asyAbbreviation| |conname| |nargs|)))) (SPADLET |page| (|htInitPageNoScroll| NIL)) (|htAddHeading| |heading|) (|htSayStandard| '|\\beginscroll |)