diff options
| -rw-r--r-- | src/ChangeLog | 12 | ||||
| -rw-r--r-- | src/boot/ast.boot | 113 | ||||
| -rw-r--r-- | src/boot/parser.boot | 15 | ||||
| -rw-r--r-- | src/boot/strap/ast.clisp | 936 | ||||
| -rw-r--r-- | src/boot/strap/parser.clisp | 25 | ||||
| -rw-r--r-- | src/interp/astr.boot | 6 | ||||
| -rw-r--r-- | src/interp/c-util.boot | 26 | ||||
| -rw-r--r-- | src/interp/category.boot | 16 | ||||
| -rw-r--r-- | src/interp/compiler.boot | 42 | ||||
| -rw-r--r-- | src/interp/database.boot | 56 | ||||
| -rw-r--r-- | src/interp/define.boot | 12 | ||||
| -rw-r--r-- | src/interp/g-util.boot | 30 | ||||
| -rw-r--r-- | src/interp/i-analy.boot | 2 | ||||
| -rw-r--r-- | src/interp/lisplib.boot | 4 | ||||
| -rw-r--r-- | src/interp/modemap.boot | 20 | ||||
| -rw-r--r-- | src/interp/parse.boot | 18 | ||||
| -rw-r--r-- | src/interp/posit.boot | 8 | ||||
| -rw-r--r-- | src/interp/postpar.boot | 14 | ||||
| -rw-r--r-- | src/interp/serror.boot | 10 | ||||
| -rw-r--r-- | src/interp/sys-utility.boot | 19 | ||||
| -rw-r--r-- | src/interp/types.boot | 109 | ||||
| -rw-r--r-- | src/lisp/core.lisp.in | 117 |
22 files changed, 811 insertions, 799 deletions
diff --git a/src/ChangeLog b/src/ChangeLog index 7bbfc32e..f2dfe950 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,15 @@ +2011-04-23 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * lisp/core.lisp.in: Export basic types and compiler data types. + * interp/modemap.boot (knownInfo): Fix latent bug uncovered by + type declarations. + * boot/ast.boot: Remove type definitions. + (bfIN): Handle DOT as loop variable. + (bfON): Likewise. Allow a loop variable to iterator over its own + tails. + * boot/parser.boot (bfTyping): Simplify. + (bpSimpleMapping): Fix thinko. + 2011-04-22 Gabriel Dos Reis <gdr@cs.tamu.edu> * boot/tokens.boot: Don't translate setDifference. diff --git a/src/boot/ast.boot b/src/boot/ast.boot index 0f09668b..2fee3a7a 100644 --- a/src/boot/ast.boot +++ b/src/boot/ast.boot @@ -55,64 +55,37 @@ $constantIdentifiers := nil ++ namespace definition. $activeNamespace := nil ---% Basic types used in Boot codes. - -%Thing <=> true - -%Boolean <=> BOOLEAN - -%String <=> STRING - -%Symbol <=> SYMBOL - -%Short <=> FIXNUM - -++ Ideally, we would like to say that a List T if either nil or a -++ cons of a T and List of T. -%List <=> LIST - -%Vector <=> VECTOR - -%Sequence <=> SEQUENCE - -++ Currently, the Boot processor uses Lisp symbol datatype for names. -++ That causes the BOOTTRAN package to contain more symbols than we would -++ like. In the future, we want to intern `on demand'. How that -++ interacts with renaming is to be worked out. -structure %Name == - %Name(%Symbol) - structure %Ast == %Command(%String) -- includer command %Lisp(%String) -- )lisp command - %Module(%Name,%List,%List) -- module declaration - %Namespace(%Name) -- namespace AxiomCore - %Import(%String) -- import module - %ImportSignature(%Name,%Signature) -- import function declaration + %Module(%Symbol,%List,%List) -- module declaration + %Namespace(%Symbol) -- namespace AxiomCore + %Import(%Symbol) -- import module + %ImportSignature(%Symbol,%Signature) -- import function declaration %TypeAlias(%Head, %List) -- type alias definition - %Signature(%Name,%Mapping) -- op: S -> T + %Signature(%Symbol,%Mapping) -- op: S -> T %Mapping(%Ast, %List) -- (S1, S2) -> T %SuffixDot(%Ast) -- x . %Quote(%Ast) -- 'x - %EqualName(%Name) -- =x -- patterns - %Colon(%Name) -- :x - %QualifiedName(%Name,%Name) -- m::x - %DefaultValue(%Name,%Ast) -- opt. value for function param. + %EqualPattern(%Ast) -- =x -- patterns + %Colon(%Symbol) -- :x + %QualifiedName(%Symbol,%Symbol) -- m::x + %DefaultValue(%Symbol,%Ast) -- opt. value for function param. %Bracket(%Ast) -- [x, y] %UnboundedSegment(%Ast) -- 3.. %BoundedSgement(%Ast,%Ast) -- 2..4 - %Tuple(%List) -- comma-separated expression sequence + %Tuple(%List) -- a, b, c, d %ColonAppend(%Ast,%Ast) -- [:y] or [x, :y] %Pretend(%Ast,%Ast) -- e : t -- hard coercion %Is(%Ast,%Ast) -- e is p -- patterns %Isnt(%Ast,%Ast) -- e isnt p -- patterns %Reduce(%Ast,%Ast) -- +/[...] - %PrefixExpr(%Name,%Ast) -- #v + %PrefixExpr(%Symbol,%Ast) -- #v %Call(%Ast,%Sequence) -- f(x, y , z) - %InfixExpr(%Name,%Ast,%Ast) -- x + y - %ConstantDefinition(%Name,%Ast) -- x == y - %Definition(%Name,%Ast,%Ast) -- f x == y - %Macro(%Name,%List,%Ast) -- m x ==> y + %InfixExpr(%Symbol,%Ast,%Ast) -- x + y + %ConstantDefinition(%Symbol,%Ast) -- x == y + %Definition(%Symbol,%Ast,%Ast) -- f x == y + %Macro(%Symbol,%List,%Ast) -- m x ==> y %Lambda(%List,%Ast) -- x +-> x**2 %SuchThat(%Ast) -- | p %Assignment(%Ast,%Ast) -- x := y @@ -151,7 +124,7 @@ bfGenSymbol()== $GenVarCounter := $GenVarCounter+1 makeSymbol strconc('"bfVar#",toString $GenVarCounter) -bfColon: %Thing -> %List +bfColon: %Thing -> %Form bfColon x== ["COLON",x] @@ -171,11 +144,11 @@ bfDot: () -> %Symbol bfDot() == "DOT" -bfSuffixDot: %Thing -> %List +bfSuffixDot: %Form -> %Form bfSuffixDot x == [x,"DOT"] -bfEqual: %Thing -> %List +bfEqual: %Form -> %Form bfEqual(name) == ["EQUAL",name] @@ -183,15 +156,15 @@ bfBracket: %Thing -> %Thing bfBracket(part) == part -bfPile: %List -> %List +bfPile: %List %Form -> %List %Form bfPile(part) == part -bfAppend: %List -> %List +bfAppend: %List %Form -> %Form bfAppend x== apply(function append,x) -bfColonAppend: (%List,%Thing) -> %List +bfColonAppend: (%List %Form,%Form) -> %Form bfColonAppend(x,y) == x = nil => y is ["BVQUOTE",:a] => ["&REST",["QUOTE",:a]] @@ -305,16 +278,30 @@ bfINON x== bfIN(x,E)== g := bfGenSymbol() - [[[g,x],[E,nil],[['SETQ,g,['CDR, g]]],[], - [['OR,['ATOM,g],['PROGN,['SETQ,x,['CAR,g]] ,'NIL]]],[]]] + vars := [g] + inits := [E] + exitCond := ['ATOM,g] + if x isnt "DOT" then + vars := [:vars,x] + inits := [:inits,nil] + exitCond := ['OR,exitCond,['PROGN,['SETQ,x,['CAR,g]] ,'NIL]] + [[vars,inits,[['SETQ,g,['CDR, g]]],[],[exitCond],[]]] bfON(x,E)== - [[[x],[E],[['SETQ,x,['CDR, x]]],[], - [['ATOM,x]],[]]] + if x is "DOT" then + x := bfGenSymbol() + -- allow a list variable to iterate over its own tails. + var := init := nil + if not symbol? E or not symbolEq?(x,E) then + var := [x] + init := [E] + [[var,init,[['SETQ,x,['CDR, x]]],[],[['ATOM,x]],[]]] -bfSuchthat p== [[[],[],[],[p],[],[]]] +bfSuchthat p == + [[[],[],[],[p],[],[]]] -bfWhile p== [[[],[],[],[],[bfNOT p],[]]] +bfWhile p == + [[[],[],[],[],[bfNOT p],[]]] bfUntil p== g:=bfGenSymbol() @@ -1126,29 +1113,29 @@ bfMain(auxfn,op)== ["QUOTE", op],["QUOTE",'cacheInfo]],["QUOTE", cacheVector]]] -bfNameOnly: %Thing -> %List +bfNameOnly: %Thing -> %Form bfNameOnly x== x="t" => ["T"] [x] -bfNameArgs: (%Thing,%Thing) -> %List +bfNameArgs: (%Thing,%Thing) -> %List %Form bfNameArgs (x,y)== y := y is ["TUPLE",:.] => rest y [y] [x,:y] -bfCreateDef: %Thing -> %List +bfCreateDef: %Thing -> %Form bfCreateDef x== x is [f] => ["DEFCONSTANT",f,["LIST",["QUOTE",f]]] a := [bfGenSymbol() for i in rest x] ["DEFUN",first x,a,["CONS",["QUOTE",first x],["LIST",:a]]] -bfCaseItem: (%Thing,%Thing) -> %List +bfCaseItem: (%Thing,%Thing) -> %Form bfCaseItem(x,y) == [x,y] -bfCase: (%Thing,%Thing) -> %List +bfCase: (%Thing,%Thing) -> %Form bfCase(x,y)== -- Introduce a temporary to hold the value of the scrutinee. -- To minimize the number of GENSYMS and assignments, we want @@ -1160,11 +1147,11 @@ bfCase(x,y)== sameObject?(g,x) => body ["LET",[[g,x]],body] -bfCaseItems: (%Thing,%List) -> %List +bfCaseItems: (%Thing,%List %Form) -> %List %Form bfCaseItems(g,x) == [bfCI(g,i,j) for [i,j] in x] -bfCI: (%Thing,%Thing,%Thing) -> %List +bfCI: (%Thing,%Thing,%Thing) -> %Form bfCI(g,x,y)== a := rest x a = nil => [first x,y] @@ -1172,7 +1159,7 @@ bfCI(g,x,y)== b = nil => [first x,y] [first x,["LET",b,y]] -bfCARCDR: (%Short,%Thing) -> %List +bfCARCDR: (%Short,%Thing) -> %Form bfCARCDR(n,g) == [makeSymbol strconc('"CA",bfDs n,'"R"),g] @@ -1201,7 +1188,7 @@ codeForCatchHandlers(g,e,cs) == ["COND",[ehTest,bfHandlers(g,["CDR",g],cs)],[true,g]]] ++ Generate code for try-catch expressions. -bfTry: (%Thing,%List) -> %Thing +bfTry: (%Thing,%List %Form) -> %Thing bfTry(e,cs) == g := gensym() cs is [:cs',f] and f is ['%Finally,s] => diff --git a/src/boot/parser.boot b/src/boot/parser.boot index e90d057e..6f625748 100644 --- a/src/boot/parser.boot +++ b/src/boot/parser.boot @@ -477,7 +477,7 @@ bpTypeAliasDefition() == ++ Signature: ++ Name COLON Mapping bpSignature() == - bpName() and bpEqKey "COLON" and bpMapping() + bpName() and bpEqKey "COLON" and bpTyping() and bpPush %Signature(bpPop2(), bpPop1()) ++ SimpleMapping: @@ -486,7 +486,7 @@ bpSignature() == bpSimpleMapping() == bpApplication() => bpEqKey "ARROW" and (bpApplication() or bpTrap()) and - bpPush %Mapping(bpPop1(), bfUntuple bpPop1()) + bpPush %Mapping(bpPop1(), [bpPop1()]) true false @@ -501,12 +501,10 @@ bpArgtypeList() == ++ Parse a mapping expression ++ Mapping: ++ ArgtypeList -> Application -++ SimpleMapping bpMapping() == bpParenthesized function bpArgtypeList and bpEqKey "ARROW" and bpApplication() and bpPush %Mapping(bpPop1(), bfUntuple bpPop1()) - or bpSimpleMapping() bpCancel()== a := bpState() @@ -601,9 +599,7 @@ bpApplication()== ++ SimpleType ++ Mapping bpTyping() == - bpApplication() and - (bpEqKey "ARROW" and (bpApplication() or bpTrap()) and - bpPush %Mapping(bpPop1(), bfUntuple bpPop1()) or true) or bpMapping() + bpMapping() or bpSimpleMapping() ++ Tagged: ++ Name : Typing @@ -791,8 +787,11 @@ bpWhile()==bpAndOr ("WHILE",function bpLogical,function bfWhile) bpUntil()==bpAndOr ("UNTIL",function bpLogical,function bfUntil) +bpFormal() == + bpVariable() or bpDot() + bpForIn()== - bpEqKey "FOR" and (bpVariable() or bpTrap()) and (bpCompMissing "IN") + bpEqKey "FOR" and (bpFormal() or bpTrap()) and (bpCompMissing "IN") and ((bpSeg() or bpTrap()) and (bpEqKey "BY" and (bpArith() or bpTrap()) and bpPush bfForInBy(bpPop3(),bpPop2(),bpPop1())) or diff --git a/src/boot/strap/ast.clisp b/src/boot/strap/ast.clisp index ad885aaa..c9805a04 100644 --- a/src/boot/strap/ast.clisp +++ b/src/boot/strap/ast.clisp @@ -11,152 +11,135 @@ (DEFPARAMETER |$activeNamespace| NIL) -(DEFTYPE |%Thing| () 'T) +(DEFUN |%Command| #0=(|bfVar#1|) (CONS '|%Command| (LIST . #0#))) -(DEFTYPE |%Boolean| () 'BOOLEAN) +(DEFUN |%Lisp| #0=(|bfVar#2|) (CONS '|%Lisp| (LIST . #0#))) -(DEFTYPE |%String| () 'STRING) - -(DEFTYPE |%Symbol| () 'SYMBOL) - -(DEFTYPE |%Short| () 'FIXNUM) - -(DEFTYPE |%List| () 'LIST) - -(DEFTYPE |%Vector| () 'VECTOR) - -(DEFTYPE |%Sequence| () 'SEQUENCE) - -(DEFUN |%Name| #0=(|bfVar#1|) (CONS '|%Name| (LIST . #0#))) - -(DEFUN |%Command| #0=(|bfVar#2|) (CONS '|%Command| (LIST . #0#))) - -(DEFUN |%Lisp| #0=(|bfVar#3|) (CONS '|%Lisp| (LIST . #0#))) - -(DEFUN |%Module| #0=(|bfVar#4| |bfVar#5| |bfVar#6|) +(DEFUN |%Module| #0=(|bfVar#3| |bfVar#4| |bfVar#5|) (CONS '|%Module| (LIST . #0#))) -(DEFUN |%Namespace| #0=(|bfVar#7|) (CONS '|%Namespace| (LIST . #0#))) +(DEFUN |%Namespace| #0=(|bfVar#6|) (CONS '|%Namespace| (LIST . #0#))) -(DEFUN |%Import| #0=(|bfVar#8|) (CONS '|%Import| (LIST . #0#))) +(DEFUN |%Import| #0=(|bfVar#7|) (CONS '|%Import| (LIST . #0#))) -(DEFUN |%ImportSignature| #0=(|bfVar#9| |bfVar#10|) +(DEFUN |%ImportSignature| #0=(|bfVar#8| |bfVar#9|) (CONS '|%ImportSignature| (LIST . #0#))) -(DEFUN |%TypeAlias| #0=(|bfVar#11| |bfVar#12|) +(DEFUN |%TypeAlias| #0=(|bfVar#10| |bfVar#11|) (CONS '|%TypeAlias| (LIST . #0#))) -(DEFUN |%Signature| #0=(|bfVar#13| |bfVar#14|) +(DEFUN |%Signature| #0=(|bfVar#12| |bfVar#13|) (CONS '|%Signature| (LIST . #0#))) -(DEFUN |%Mapping| #0=(|bfVar#15| |bfVar#16|) +(DEFUN |%Mapping| #0=(|bfVar#14| |bfVar#15|) (CONS '|%Mapping| (LIST . #0#))) -(DEFUN |%SuffixDot| #0=(|bfVar#17|) (CONS '|%SuffixDot| (LIST . #0#))) +(DEFUN |%SuffixDot| #0=(|bfVar#16|) (CONS '|%SuffixDot| (LIST . #0#))) -(DEFUN |%Quote| #0=(|bfVar#18|) (CONS '|%Quote| (LIST . #0#))) +(DEFUN |%Quote| #0=(|bfVar#17|) (CONS '|%Quote| (LIST . #0#))) -(DEFUN |%EqualName| #0=(|bfVar#19|) (CONS '|%EqualName| (LIST . #0#))) +(DEFUN |%EqualPattern| #0=(|bfVar#18|) + (CONS '|%EqualPattern| (LIST . #0#))) -(DEFUN |%Colon| #0=(|bfVar#20|) (CONS '|%Colon| (LIST . #0#))) +(DEFUN |%Colon| #0=(|bfVar#19|) (CONS '|%Colon| (LIST . #0#))) -(DEFUN |%QualifiedName| #0=(|bfVar#21| |bfVar#22|) +(DEFUN |%QualifiedName| #0=(|bfVar#20| |bfVar#21|) (CONS '|%QualifiedName| (LIST . #0#))) -(DEFUN |%DefaultValue| #0=(|bfVar#23| |bfVar#24|) +(DEFUN |%DefaultValue| #0=(|bfVar#22| |bfVar#23|) (CONS '|%DefaultValue| (LIST . #0#))) -(DEFUN |%Bracket| #0=(|bfVar#25|) (CONS '|%Bracket| (LIST . #0#))) +(DEFUN |%Bracket| #0=(|bfVar#24|) (CONS '|%Bracket| (LIST . #0#))) -(DEFUN |%UnboundedSegment| #0=(|bfVar#26|) +(DEFUN |%UnboundedSegment| #0=(|bfVar#25|) (CONS '|%UnboundedSegment| (LIST . #0#))) -(DEFUN |%BoundedSgement| #0=(|bfVar#27| |bfVar#28|) +(DEFUN |%BoundedSgement| #0=(|bfVar#26| |bfVar#27|) (CONS '|%BoundedSgement| (LIST . #0#))) -(DEFUN |%Tuple| #0=(|bfVar#29|) (CONS '|%Tuple| (LIST . #0#))) +(DEFUN |%Tuple| #0=(|bfVar#28|) (CONS '|%Tuple| (LIST . #0#))) -(DEFUN |%ColonAppend| #0=(|bfVar#30| |bfVar#31|) +(DEFUN |%ColonAppend| #0=(|bfVar#29| |bfVar#30|) (CONS '|%ColonAppend| (LIST . #0#))) -(DEFUN |%Pretend| #0=(|bfVar#32| |bfVar#33|) +(DEFUN |%Pretend| #0=(|bfVar#31| |bfVar#32|) (CONS '|%Pretend| (LIST . #0#))) -(DEFUN |%Is| #0=(|bfVar#34| |bfVar#35|) (CONS '|%Is| (LIST . #0#))) +(DEFUN |%Is| #0=(|bfVar#33| |bfVar#34|) (CONS '|%Is| (LIST . #0#))) -(DEFUN |%Isnt| #0=(|bfVar#36| |bfVar#37|) +(DEFUN |%Isnt| #0=(|bfVar#35| |bfVar#36|) (CONS '|%Isnt| (LIST . #0#))) -(DEFUN |%Reduce| #0=(|bfVar#38| |bfVar#39|) +(DEFUN |%Reduce| #0=(|bfVar#37| |bfVar#38|) (CONS '|%Reduce| (LIST . #0#))) -(DEFUN |%PrefixExpr| #0=(|bfVar#40| |bfVar#41|) +(DEFUN |%PrefixExpr| #0=(|bfVar#39| |bfVar#40|) (CONS '|%PrefixExpr| (LIST . #0#))) -(DEFUN |%Call| #0=(|bfVar#42| |bfVar#43|) +(DEFUN |%Call| #0=(|bfVar#41| |bfVar#42|) (CONS '|%Call| (LIST . #0#))) -(DEFUN |%InfixExpr| #0=(|bfVar#44| |bfVar#45| |bfVar#46|) +(DEFUN |%InfixExpr| #0=(|bfVar#43| |bfVar#44| |bfVar#45|) (CONS '|%InfixExpr| (LIST . #0#))) -(DEFUN |%ConstantDefinition| #0=(|bfVar#47| |bfVar#48|) +(DEFUN |%ConstantDefinition| #0=(|bfVar#46| |bfVar#47|) (CONS '|%ConstantDefinition| (LIST . #0#))) -(DEFUN |%Definition| #0=(|bfVar#49| |bfVar#50| |bfVar#51|) +(DEFUN |%Definition| #0=(|bfVar#48| |bfVar#49| |bfVar#50|) (CONS '|%Definition| (LIST . #0#))) -(DEFUN |%Macro| #0=(|bfVar#52| |bfVar#53| |bfVar#54|) +(DEFUN |%Macro| #0=(|bfVar#51| |bfVar#52| |bfVar#53|) (CONS '|%Macro| (LIST . #0#))) -(DEFUN |%Lambda| #0=(|bfVar#55| |bfVar#56|) +(DEFUN |%Lambda| #0=(|bfVar#54| |bfVar#55|) (CONS '|%Lambda| (LIST . #0#))) -(DEFUN |%SuchThat| #0=(|bfVar#57|) (CONS '|%SuchThat| (LIST . #0#))) +(DEFUN |%SuchThat| #0=(|bfVar#56|) (CONS '|%SuchThat| (LIST . #0#))) -(DEFUN |%Assignment| #0=(|bfVar#58| |bfVar#59|) +(DEFUN |%Assignment| #0=(|bfVar#57| |bfVar#58|) (CONS '|%Assignment| (LIST . #0#))) -(DEFUN |%While| #0=(|bfVar#60|) (CONS '|%While| (LIST . #0#))) +(DEFUN |%While| #0=(|bfVar#59|) (CONS '|%While| (LIST . #0#))) -(DEFUN |%Until| #0=(|bfVar#61|) (CONS '|%Until| (LIST . #0#))) +(DEFUN |%Until| #0=(|bfVar#60|) (CONS '|%Until| (LIST . #0#))) -(DEFUN |%For| #0=(|bfVar#62| |bfVar#63| |bfVar#64|) +(DEFUN |%For| #0=(|bfVar#61| |bfVar#62| |bfVar#63|) (CONS '|%For| (LIST . #0#))) -(DEFUN |%Implies| #0=(|bfVar#65| |bfVar#66|) +(DEFUN |%Implies| #0=(|bfVar#64| |bfVar#65|) (CONS '|%Implies| (LIST . #0#))) -(DEFUN |%Iterators| #0=(|bfVar#67|) (CONS '|%Iterators| (LIST . #0#))) +(DEFUN |%Iterators| #0=(|bfVar#66|) (CONS '|%Iterators| (LIST . #0#))) -(DEFUN |%Cross| #0=(|bfVar#68|) (CONS '|%Cross| (LIST . #0#))) +(DEFUN |%Cross| #0=(|bfVar#67|) (CONS '|%Cross| (LIST . #0#))) -(DEFUN |%Repeat| #0=(|bfVar#69| |bfVar#70|) +(DEFUN |%Repeat| #0=(|bfVar#68| |bfVar#69|) (CONS '|%Repeat| (LIST . #0#))) -(DEFUN |%Pile| #0=(|bfVar#71|) (CONS '|%Pile| (LIST . #0#))) +(DEFUN |%Pile| #0=(|bfVar#70|) (CONS '|%Pile| (LIST . #0#))) -(DEFUN |%Append| #0=(|bfVar#72|) (CONS '|%Append| (LIST . #0#))) +(DEFUN |%Append| #0=(|bfVar#71|) (CONS '|%Append| (LIST . #0#))) -(DEFUN |%Case| #0=(|bfVar#73| |bfVar#74|) +(DEFUN |%Case| #0=(|bfVar#72| |bfVar#73|) (CONS '|%Case| (LIST . #0#))) -(DEFUN |%Return| #0=(|bfVar#75|) (CONS '|%Return| (LIST . #0#))) +(DEFUN |%Return| #0=(|bfVar#74|) (CONS '|%Return| (LIST . #0#))) -(DEFUN |%Leave| #0=(|bfVar#76|) (CONS '|%Leave| (LIST . #0#))) +(DEFUN |%Leave| #0=(|bfVar#75|) (CONS '|%Leave| (LIST . #0#))) -(DEFUN |%Throw| #0=(|bfVar#77|) (CONS '|%Throw| (LIST . #0#))) +(DEFUN |%Throw| #0=(|bfVar#76|) (CONS '|%Throw| (LIST . #0#))) -(DEFUN |%Catch| #0=(|bfVar#78| |bfVar#79|) +(DEFUN |%Catch| #0=(|bfVar#77| |bfVar#78|) (CONS '|%Catch| (LIST . #0#))) -(DEFUN |%Finally| #0=(|bfVar#80|) (CONS '|%Finally| (LIST . #0#))) +(DEFUN |%Finally| #0=(|bfVar#79|) (CONS '|%Finally| (LIST . #0#))) -(DEFUN |%Try| #0=(|bfVar#81| |bfVar#82|) (CONS '|%Try| (LIST . #0#))) +(DEFUN |%Try| #0=(|bfVar#80| |bfVar#81|) (CONS '|%Try| (LIST . #0#))) -(DEFUN |%Where| #0=(|bfVar#83| |bfVar#84|) +(DEFUN |%Where| #0=(|bfVar#82| |bfVar#83|) (CONS '|%Where| (LIST . #0#))) -(DEFUN |%Structure| #0=(|bfVar#85| |bfVar#86|) +(DEFUN |%Structure| #0=(|bfVar#84| |bfVar#85|) (CONS '|%Structure| (LIST . #0#))) (DEFPARAMETER |$inDefIS| NIL) @@ -171,7 +154,7 @@ (SETQ |$GenVarCounter| (+ |$GenVarCounter| 1)) (INTERN (CONCAT "bfVar#" (WRITE-TO-STRING |$GenVarCounter|))))) -(DECLAIM (FTYPE (FUNCTION (|%Thing|) |%List|) |bfColon|)) +(DECLAIM (FTYPE (FUNCTION (|%Thing|) |%Form|) |bfColon|)) (DEFUN |bfColon| (|x|) (LIST 'COLON |x|)) @@ -194,11 +177,11 @@ (DEFUN |bfDot| () 'DOT) -(DECLAIM (FTYPE (FUNCTION (|%Thing|) |%List|) |bfSuffixDot|)) +(DECLAIM (FTYPE (FUNCTION (|%Form|) |%Form|) |bfSuffixDot|)) (DEFUN |bfSuffixDot| (|x|) (LIST |x| 'DOT)) -(DECLAIM (FTYPE (FUNCTION (|%Thing|) |%List|) |bfEqual|)) +(DECLAIM (FTYPE (FUNCTION (|%Form|) |%Form|) |bfEqual|)) (DEFUN |bfEqual| (|name|) (LIST 'EQUAL |name|)) @@ -206,15 +189,17 @@ (DEFUN |bfBracket| (|part|) |part|) -(DECLAIM (FTYPE (FUNCTION (|%List|) |%List|) |bfPile|)) +(DECLAIM (FTYPE (FUNCTION ((|%List| |%Form|)) (|%List| |%Form|)) + |bfPile|)) (DEFUN |bfPile| (|part|) |part|) -(DECLAIM (FTYPE (FUNCTION (|%List|) |%List|) |bfAppend|)) +(DECLAIM (FTYPE (FUNCTION ((|%List| |%Form|)) |%Form|) |bfAppend|)) (DEFUN |bfAppend| (|x|) (APPLY #'APPEND |x|)) -(DECLAIM (FTYPE (FUNCTION (|%List| |%Thing|) |%List|) |bfColonAppend|)) +(DECLAIM (FTYPE (FUNCTION ((|%List| |%Form|) |%Form|) |%Form|) + |bfColonAppend|)) (DEFUN |bfColonAppend| (|x| |y|) (PROG (|a|) @@ -260,21 +245,21 @@ (PROGN (SETQ |a| (COND ((|bfTupleP| |b|) (CDR |b|)) (T (LIST |b|)))) (COND - ((LET ((|bfVar#88| NIL) (|bfVar#87| |a|) (|x| NIL)) + ((LET ((|bfVar#87| NIL) (|bfVar#86| |a|) (|x| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#87|) - (PROGN (SETQ |x| (CAR |bfVar#87|)) NIL)) - (RETURN |bfVar#88|)) + ((OR (ATOM |bfVar#86|) + (PROGN (SETQ |x| (CAR |bfVar#86|)) NIL)) + (RETURN |bfVar#87|)) (T (PROGN - (SETQ |bfVar#88| + (SETQ |bfVar#87| (AND (CONSP |x|) (EQ (CAR |x|) 'COLON) (PROGN (SETQ |ISTMP#1| (CDR |x|)) (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)))))) - (COND (|bfVar#88| (RETURN |bfVar#88|)))))) - (SETQ |bfVar#87| (CDR |bfVar#87|)))) + (COND (|bfVar#87| (RETURN |bfVar#87|)))))) + (SETQ |bfVar#86| (CDR |bfVar#86|)))) (|bfMakeCons| |a|)) (T (CONS 'LIST |a|))))))) @@ -374,22 +359,37 @@ (T (|bfIN| |id| |whole|))))))) (DEFUN |bfIN| (|x| E) - (PROG (|g|) + (PROG (|exitCond| |inits| |vars| |g|) (RETURN (PROGN (SETQ |g| (|bfGenSymbol|)) - (LIST (LIST (LIST |g| |x|) (LIST E NIL) + (SETQ |vars| (LIST |g|)) + (SETQ |inits| (LIST E)) + (SETQ |exitCond| (LIST 'ATOM |g|)) + (COND + ((NOT (EQ |x| 'DOT)) + (SETQ |vars| (APPEND |vars| (CONS |x| NIL))) + (SETQ |inits| (APPEND |inits| (CONS NIL NIL))) + (SETQ |exitCond| + (LIST 'OR |exitCond| + (LIST 'PROGN (LIST 'SETQ |x| (LIST 'CAR |g|)) + 'NIL))))) + (LIST (LIST |vars| |inits| (LIST (LIST 'SETQ |g| (LIST 'CDR |g|))) NIL - (LIST (LIST 'OR (LIST 'ATOM |g|) - (LIST 'PROGN - (LIST 'SETQ |x| (LIST 'CAR |g|)) - 'NIL))) - NIL)))))) + (LIST |exitCond|) NIL)))))) (DEFUN |bfON| (|x| E) - (LIST (LIST (LIST |x|) (LIST E) - (LIST (LIST 'SETQ |x| (LIST 'CDR |x|))) NIL - (LIST (LIST 'ATOM |x|)) NIL))) + (PROG (|var| |init|) + (RETURN + (PROGN + (COND ((EQ |x| 'DOT) (SETQ |x| (|bfGenSymbol|)))) + (SETQ |var| (SETQ |init| NIL)) + (COND + ((OR (NOT (SYMBOLP E)) (NOT (EQ |x| E))) + (SETQ |var| (LIST |x|)) (SETQ |init| (LIST E)))) + (LIST (LIST |var| |init| + (LIST (LIST 'SETQ |x| (LIST 'CDR |x|))) NIL + (LIST (LIST 'ATOM |x|)) NIL)))))) (DEFUN |bfSuchthat| (|p|) (LIST (LIST NIL NIL NIL (LIST |p|) NIL NIL))) @@ -426,19 +426,19 @@ (COND ((NULL |iters|) (LIST NIL NIL NIL NIL NIL NIL)) (T (SETQ |f| (CAR |iters|)) (SETQ |r| (|bfSep| (CDR |iters|))) - (LET ((|bfVar#91| NIL) (|bfVar#89| |f|) (|i| NIL) - (|bfVar#90| |r|) (|j| NIL)) + (LET ((|bfVar#90| NIL) (|bfVar#88| |f|) (|i| NIL) + (|bfVar#89| |r|) (|j| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#89|) - (PROGN (SETQ |i| (CAR |bfVar#89|)) NIL) - (ATOM |bfVar#90|) - (PROGN (SETQ |j| (CAR |bfVar#90|)) NIL)) - (RETURN (|reverse!| |bfVar#91|))) - (T (SETQ |bfVar#91| - (CONS (APPEND |i| |j|) |bfVar#91|)))) - (SETQ |bfVar#89| (CDR |bfVar#89|)) - (SETQ |bfVar#90| (CDR |bfVar#90|))))))))) + ((OR (ATOM |bfVar#88|) + (PROGN (SETQ |i| (CAR |bfVar#88|)) NIL) + (ATOM |bfVar#89|) + (PROGN (SETQ |j| (CAR |bfVar#89|)) NIL)) + (RETURN (|reverse!| |bfVar#90|))) + (T (SETQ |bfVar#90| + (CONS (APPEND |i| |j|) |bfVar#90|)))) + (SETQ |bfVar#88| (CDR |bfVar#88|)) + (SETQ |bfVar#89| (CDR |bfVar#89|))))))))) (DEFUN |bfReduce| (|op| |y|) (PROG (|it| |ny| |g2| |body| |g1| |g| |init| |a|) @@ -560,25 +560,25 @@ (COND (|vars| (SETQ |loop| (LIST 'LET - (LET ((|bfVar#94| NIL) - (|bfVar#92| |vars|) (|v| NIL) - (|bfVar#93| |inits|) (|i| NIL)) + (LET ((|bfVar#93| NIL) + (|bfVar#91| |vars|) (|v| NIL) + (|bfVar#92| |inits|) (|i| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#92|) + ((OR (ATOM |bfVar#91|) (PROGN - (SETQ |v| (CAR |bfVar#92|)) + (SETQ |v| (CAR |bfVar#91|)) NIL) - (ATOM |bfVar#93|) + (ATOM |bfVar#92|) (PROGN - (SETQ |i| (CAR |bfVar#93|)) + (SETQ |i| (CAR |bfVar#92|)) NIL)) - (RETURN (|reverse!| |bfVar#94|))) + (RETURN (|reverse!| |bfVar#93|))) (T - (SETQ |bfVar#94| - (CONS (LIST |v| |i|) |bfVar#94|)))) - (SETQ |bfVar#92| (CDR |bfVar#92|)) - (SETQ |bfVar#93| (CDR |bfVar#93|)))) + (SETQ |bfVar#93| + (CONS (LIST |v| |i|) |bfVar#93|)))) + (SETQ |bfVar#91| (CDR |bfVar#91|)) + (SETQ |bfVar#92| (CDR |bfVar#92|)))) |loop|)))) |loop|)))) @@ -1109,16 +1109,16 @@ (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) (PROGN (SETQ |seq| (CAR |ISTMP#1|)) T))) (CONSP |seq|) - (LET ((|bfVar#96| T) (|bfVar#95| |seq|) (|y| NIL)) + (LET ((|bfVar#95| T) (|bfVar#94| |seq|) (|y| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#95|) - (PROGN (SETQ |y| (CAR |bfVar#95|)) NIL)) - (RETURN |bfVar#96|)) + ((OR (ATOM |bfVar#94|) + (PROGN (SETQ |y| (CAR |bfVar#94|)) NIL)) + (RETURN |bfVar#95|)) (T (PROGN - (SETQ |bfVar#96| (APPLY |pred| |y| NIL)) - (COND ((NOT |bfVar#96|) (RETURN NIL)))))) - (SETQ |bfVar#95| (CDR |bfVar#95|)))))))) + (SETQ |bfVar#95| (APPLY |pred| |y| NIL)) + (COND ((NOT |bfVar#95|) (RETURN NIL)))))) + (SETQ |bfVar#94| (CDR |bfVar#94|)))))))) (DEFUN |bfMember| (|var| |seq|) (PROG (|x| |ISTMP#2| |ISTMP#1|) @@ -1215,32 +1215,32 @@ ((NULL |l|) NIL) ((NULL (CDR |l|)) (CAR |l|)) (T (CONS 'OR - (LET ((|bfVar#98| NIL) (|bfVar#97| |l|) (|c| NIL)) + (LET ((|bfVar#97| NIL) (|bfVar#96| |l|) (|c| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#97|) - (PROGN (SETQ |c| (CAR |bfVar#97|)) NIL)) - (RETURN (|reverse!| |bfVar#98|))) - (T (SETQ |bfVar#98| + ((OR (ATOM |bfVar#96|) + (PROGN (SETQ |c| (CAR |bfVar#96|)) NIL)) + (RETURN (|reverse!| |bfVar#97|))) + (T (SETQ |bfVar#97| (APPEND (|reverse| (|bfFlatten| 'OR |c|)) - |bfVar#98|)))) - (SETQ |bfVar#97| (CDR |bfVar#97|)))))))) + |bfVar#97|)))) + (SETQ |bfVar#96| (CDR |bfVar#96|)))))))) (DEFUN |bfAND| (|l|) (COND ((NULL |l|) T) ((NULL (CDR |l|)) (CAR |l|)) (T (CONS 'AND - (LET ((|bfVar#100| NIL) (|bfVar#99| |l|) (|c| NIL)) + (LET ((|bfVar#99| NIL) (|bfVar#98| |l|) (|c| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#99|) - (PROGN (SETQ |c| (CAR |bfVar#99|)) NIL)) - (RETURN (|reverse!| |bfVar#100|))) - (T (SETQ |bfVar#100| + ((OR (ATOM |bfVar#98|) + (PROGN (SETQ |c| (CAR |bfVar#98|)) NIL)) + (RETURN (|reverse!| |bfVar#99|))) + (T (SETQ |bfVar#99| (APPEND (|reverse| (|bfFlatten| 'AND |c|)) - |bfVar#100|)))) - (SETQ |bfVar#99| (CDR |bfVar#99|)))))))) + |bfVar#99|)))) + (SETQ |bfVar#98| (CDR |bfVar#98|)))))))) (DEFUN |defQuoteId| (|x|) (AND (CONSP |x|) (EQ (CAR |x|) 'QUOTE) (SYMBOLP (CADR |x|)))) @@ -1303,52 +1303,52 @@ (SETQ |nargl| (CADDR . #0#)) (SETQ |largl| (CADDDR . #0#)) (SETQ |sb| - (LET ((|bfVar#103| NIL) (|bfVar#101| |nargl|) (|i| NIL) - (|bfVar#102| |sgargl|) (|j| NIL)) + (LET ((|bfVar#102| NIL) (|bfVar#100| |nargl|) (|i| NIL) + (|bfVar#101| |sgargl|) (|j| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#101|) - (PROGN (SETQ |i| (CAR |bfVar#101|)) NIL) - (ATOM |bfVar#102|) - (PROGN (SETQ |j| (CAR |bfVar#102|)) NIL)) - (RETURN (|reverse!| |bfVar#103|))) - (T (SETQ |bfVar#103| - (CONS (CONS |i| |j|) |bfVar#103|)))) - (SETQ |bfVar#101| (CDR |bfVar#101|)) - (SETQ |bfVar#102| (CDR |bfVar#102|))))) + ((OR (ATOM |bfVar#100|) + (PROGN (SETQ |i| (CAR |bfVar#100|)) NIL) + (ATOM |bfVar#101|) + (PROGN (SETQ |j| (CAR |bfVar#101|)) NIL)) + (RETURN (|reverse!| |bfVar#102|))) + (T (SETQ |bfVar#102| + (CONS (CONS |i| |j|) |bfVar#102|)))) + (SETQ |bfVar#100| (CDR |bfVar#100|)) + (SETQ |bfVar#101| (CDR |bfVar#101|))))) (SETQ |body| (SUBLIS |sb| |body|)) (SETQ |sb2| - (LET ((|bfVar#106| NIL) (|bfVar#104| |sgargl|) (|i| NIL) - (|bfVar#105| |largl|) (|j| NIL)) + (LET ((|bfVar#105| NIL) (|bfVar#103| |sgargl|) (|i| NIL) + (|bfVar#104| |largl|) (|j| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#104|) - (PROGN (SETQ |i| (CAR |bfVar#104|)) NIL) - (ATOM |bfVar#105|) - (PROGN (SETQ |j| (CAR |bfVar#105|)) NIL)) - (RETURN (|reverse!| |bfVar#106|))) - (T (SETQ |bfVar#106| + ((OR (ATOM |bfVar#103|) + (PROGN (SETQ |i| (CAR |bfVar#103|)) NIL) + (ATOM |bfVar#104|) + (PROGN (SETQ |j| (CAR |bfVar#104|)) NIL)) + (RETURN (|reverse!| |bfVar#105|))) + (T (SETQ |bfVar#105| (CONS (LIST 'CONS (LIST 'QUOTE |i|) |j|) - |bfVar#106|)))) - (SETQ |bfVar#104| (CDR |bfVar#104|)) - (SETQ |bfVar#105| (CDR |bfVar#105|))))) + |bfVar#105|)))) + (SETQ |bfVar#103| (CDR |bfVar#103|)) + (SETQ |bfVar#104| (CDR |bfVar#104|))))) (SETQ |body| (LIST 'SUBLIS (CONS 'LIST |sb2|) (LIST 'QUOTE |body|))) (SETQ |lamex| (LIST 'MLAMBDA |gargl| |body|)) (SETQ |def| (LIST |op| |lamex|)) (CONS (|shoeComp| |def|) - (LET ((|bfVar#108| NIL) (|bfVar#107| |$wheredefs|) + (LET ((|bfVar#107| NIL) (|bfVar#106| |$wheredefs|) (|d| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#107|) - (PROGN (SETQ |d| (CAR |bfVar#107|)) NIL)) - (RETURN (|reverse!| |bfVar#108|))) - (T (SETQ |bfVar#108| + ((OR (ATOM |bfVar#106|) + (PROGN (SETQ |d| (CAR |bfVar#106|)) NIL)) + (RETURN (|reverse!| |bfVar#107|))) + (T (SETQ |bfVar#107| (APPEND (|reverse| (|shoeComps| (|bfDef1| |d|))) - |bfVar#108|)))) - (SETQ |bfVar#107| (CDR |bfVar#107|))))))))) + |bfVar#107|)))) + (SETQ |bfVar#106| (CDR |bfVar#106|))))))))) (DEFUN |bfGargl| (|argl|) (PROG (|f| |d| |c| |b| |a| |LETTMP#1|) @@ -1368,13 +1368,13 @@ (LIST (CONS |f| |a|) (CONS |f| |b|) (CONS (CAR |argl|) |c|) (CONS |f| |d|))))))))) -(DEFUN |bfDef1| (|bfVar#109|) +(DEFUN |bfDef1| (|bfVar#108|) (PROG (|arglp| |control| |quotes| |LETTMP#1| |argl| |body| |args| |op|) (RETURN (PROGN - (SETQ |op| (CAR |bfVar#109|)) - (SETQ |args| (CADR . #0=(|bfVar#109|))) + (SETQ |op| (CAR |bfVar#108|)) + (SETQ |args| (CADR . #0=(|bfVar#108|))) (SETQ |body| (CADDR . #0#)) (SETQ |argl| (COND @@ -1415,30 +1415,30 @@ (SETQ |arg1| (CADDR . #0#)) (SETQ |body1| (CDDDR . #0#)) (|bfCompHash| |op1| |arg1| |body1|)) (T (|bfTuple| - (LET ((|bfVar#111| NIL) - (|bfVar#110| + (LET ((|bfVar#110| NIL) + (|bfVar#109| (CONS (LIST |op| |args| |body|) |$wheredefs|)) (|d| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#110|) - (PROGN (SETQ |d| (CAR |bfVar#110|)) NIL)) - (RETURN (|reverse!| |bfVar#111|))) - (T (SETQ |bfVar#111| + ((OR (ATOM |bfVar#109|) + (PROGN (SETQ |d| (CAR |bfVar#109|)) NIL)) + (RETURN (|reverse!| |bfVar#110|))) + (T (SETQ |bfVar#110| (APPEND (|reverse| (|shoeComps| (|bfDef1| |d|))) - |bfVar#111|)))) - (SETQ |bfVar#110| (CDR |bfVar#110|)))))))))) + |bfVar#110|)))) + (SETQ |bfVar#109| (CDR |bfVar#109|)))))))))) (DEFUN |shoeComps| (|x|) - (LET ((|bfVar#113| NIL) (|bfVar#112| |x|) (|def| NIL)) + (LET ((|bfVar#112| NIL) (|bfVar#111| |x|) (|def| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#112|) - (PROGN (SETQ |def| (CAR |bfVar#112|)) NIL)) - (RETURN (|reverse!| |bfVar#113|))) - (T (SETQ |bfVar#113| (CONS (|shoeComp| |def|) |bfVar#113|)))) - (SETQ |bfVar#112| (CDR |bfVar#112|))))) + ((OR (ATOM |bfVar#111|) + (PROGN (SETQ |def| (CAR |bfVar#111|)) NIL)) + (RETURN (|reverse!| |bfVar#112|))) + (T (SETQ |bfVar#112| (CONS (|shoeComp| |def|) |bfVar#112|)))) + (SETQ |bfVar#111| (CDR |bfVar#111|))))) (DEFUN |shoeComp| (|x|) (PROG (|a|) @@ -1583,16 +1583,16 @@ ((|symbolMember?| |op| '(LET PROG LOOP BLOCK DECLARE LAMBDA)) NIL) - ((LET ((|bfVar#115| NIL) (|bfVar#114| |body|) (|t| NIL)) + ((LET ((|bfVar#114| NIL) (|bfVar#113| |body|) (|t| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#114|) - (PROGN (SETQ |t| (CAR |bfVar#114|)) NIL)) - (RETURN |bfVar#115|)) + ((OR (ATOM |bfVar#113|) + (PROGN (SETQ |t| (CAR |bfVar#113|)) NIL)) + (RETURN |bfVar#114|)) (T (PROGN - (SETQ |bfVar#115| (|needsPROG| |t|)) - (COND (|bfVar#115| (RETURN |bfVar#115|)))))) - (SETQ |bfVar#114| (CDR |bfVar#114|)))) + (SETQ |bfVar#114| (|needsPROG| |t|)) + (COND (|bfVar#114| (RETURN |bfVar#114|)))))) + (SETQ |bfVar#113| (CDR |bfVar#113|)))) T) (T NIL))))))) @@ -1687,11 +1687,11 @@ ((EQ U '|%Leave|) (RPLACA |x| 'RETURN)) ((|symbolMember?| U '(PROG LAMBDA)) (SETQ |newbindings| NIL) - (LET ((|bfVar#116| (CADR |x|)) (|y| NIL)) + (LET ((|bfVar#115| (CADR |x|)) (|y| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#116|) - (PROGN (SETQ |y| (CAR |bfVar#116|)) NIL)) + ((OR (ATOM |bfVar#115|) + (PROGN (SETQ |y| (CAR |bfVar#115|)) NIL)) (RETURN NIL)) (T (COND ((NOT (MEMQ |y| |$locVars|)) @@ -1700,22 +1700,22 @@ (SETQ |$locVars| (CONS |y| |$locVars|)) (SETQ |newbindings| (CONS |y| |newbindings|)))))))) - (SETQ |bfVar#116| (CDR |bfVar#116|)))) + (SETQ |bfVar#115| (CDR |bfVar#115|)))) (SETQ |res| (|shoeCompTran1| (CDDR |x|))) (SETQ |$locVars| - (LET ((|bfVar#118| NIL) (|bfVar#117| |$locVars|) + (LET ((|bfVar#117| NIL) (|bfVar#116| |$locVars|) (|y| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#117|) + ((OR (ATOM |bfVar#116|) (PROGN - (SETQ |y| (CAR |bfVar#117|)) + (SETQ |y| (CAR |bfVar#116|)) NIL)) - (RETURN (|reverse!| |bfVar#118|))) + (RETURN (|reverse!| |bfVar#117|))) (T (AND (NOT (MEMQ |y| |newbindings|)) - (SETQ |bfVar#118| - (CONS |y| |bfVar#118|))))) - (SETQ |bfVar#117| (CDR |bfVar#117|)))))) + (SETQ |bfVar#117| + (CONS |y| |bfVar#117|))))) + (SETQ |bfVar#116| (CDR |bfVar#116|)))))) (T (|shoeCompTran1| (CAR |x|)) (|shoeCompTran1| (CDR |x|))))))))) @@ -1806,13 +1806,13 @@ (RETURN (PROGN (SETQ |a| - (LET ((|bfVar#119| NIL) (|c| |l|)) + (LET ((|bfVar#118| NIL) (|c| |l|)) (LOOP (COND - ((ATOM |c|) (RETURN (|reverse!| |bfVar#119|))) - (T (SETQ |bfVar#119| + ((ATOM |c|) (RETURN (|reverse!| |bfVar#118|))) + (T (SETQ |bfVar#118| (APPEND (|reverse| (|bfFlattenSeq| |c|)) - |bfVar#119|)))) + |bfVar#118|)))) (SETQ |c| (CDR |c|))))) (COND ((NULL |a|) NIL) @@ -1830,17 +1830,17 @@ ((AND (CONSP |f|) (EQ (CAR |f|) 'PROGN)) (COND ((CDR |x|) - (LET ((|bfVar#121| NIL) (|bfVar#120| (CDR |f|)) + (LET ((|bfVar#120| NIL) (|bfVar#119| (CDR |f|)) (|i| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#120|) - (PROGN (SETQ |i| (CAR |bfVar#120|)) NIL)) - (RETURN (|reverse!| |bfVar#121|))) + ((OR (ATOM |bfVar#119|) + (PROGN (SETQ |i| (CAR |bfVar#119|)) NIL)) + (RETURN (|reverse!| |bfVar#120|))) (T (AND (NOT (ATOM |i|)) - (SETQ |bfVar#121| - (CONS |i| |bfVar#121|))))) - (SETQ |bfVar#120| (CDR |bfVar#120|))))) + (SETQ |bfVar#120| + (CONS |i| |bfVar#120|))))) + (SETQ |bfVar#119| (CDR |bfVar#119|))))) (T (CDR |f|)))) (T (LIST |f|)))))))) @@ -1889,11 +1889,11 @@ (COND ((NULL |l|) NIL) (T (SETQ |transform| - (LET ((|bfVar#123| NIL) (|bfVar#122| |l|) (|x| NIL)) + (LET ((|bfVar#122| NIL) (|bfVar#121| |l|) (|x| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#122|) - (PROGN (SETQ |x| (CAR |bfVar#122|)) NIL) + ((OR (ATOM |bfVar#121|) + (PROGN (SETQ |x| (CAR |bfVar#121|)) NIL) (NOT (AND (CONSP |x|) (EQ (CAR |x|) 'COND) (PROGN (SETQ |ISTMP#1| (CDR |x|)) @@ -1927,11 +1927,11 @@ (SETQ |b| (CAR |ISTMP#5|)) T)))))))))))))) - (RETURN (|reverse!| |bfVar#123|))) - (T (SETQ |bfVar#123| + (RETURN (|reverse!| |bfVar#122|))) + (T (SETQ |bfVar#122| (CONS (|bfAlternative| |a| |b|) - |bfVar#123|)))) - (SETQ |bfVar#122| (CDR |bfVar#122|))))) + |bfVar#122|)))) + (SETQ |bfVar#121| (CDR |bfVar#121|))))) (SETQ |no| (LENGTH |transform|)) (SETQ |before| (|bfTake| |no| |l|)) (SETQ |aft| (|bfDrop| |no| |l|)) @@ -1963,17 +1963,17 @@ (SETQ |defs| (CADR . #0=(|LETTMP#1|))) (SETQ |nondefs| (CADDR . #0#)) (SETQ |a| - (LET ((|bfVar#125| NIL) (|bfVar#124| |defs|) (|d| NIL)) + (LET ((|bfVar#124| NIL) (|bfVar#123| |defs|) (|d| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#124|) - (PROGN (SETQ |d| (CAR |bfVar#124|)) NIL)) - (RETURN (|reverse!| |bfVar#125|))) - (T (SETQ |bfVar#125| + ((OR (ATOM |bfVar#123|) + (PROGN (SETQ |d| (CAR |bfVar#123|)) NIL)) + (RETURN (|reverse!| |bfVar#124|))) + (T (SETQ |bfVar#124| (CONS (LIST (CAR |d|) (CADR |d|) (|bfSUBLIS| |opassoc| (CADDR |d|))) - |bfVar#125|)))) - (SETQ |bfVar#124| (CDR |bfVar#124|))))) + |bfVar#124|)))) + (SETQ |bfVar#123| (CDR |bfVar#123|))))) (SETQ |$wheredefs| (APPEND |a| |$wheredefs|)) (|bfMKPROGN| (|bfSUBLIS| |opassoc| (|append!| |nondefs| (LIST |expr|)))))))) @@ -2033,12 +2033,13 @@ (LIST 'QUOTE '|cacheInfo|)) (LIST 'QUOTE |cacheVector|)))))))) -(DECLAIM (FTYPE (FUNCTION (|%Thing|) |%List|) |bfNameOnly|)) +(DECLAIM (FTYPE (FUNCTION (|%Thing|) |%Form|) |bfNameOnly|)) (DEFUN |bfNameOnly| (|x|) (COND ((EQ |x| '|t|) (LIST 'T)) (T (LIST |x|)))) -(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing|) |%List|) |bfNameArgs|)) +(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing|) (|%List| |%Form|)) + |bfNameArgs|)) (DEFUN |bfNameArgs| (|x| |y|) (PROGN @@ -2048,7 +2049,7 @@ (T (LIST |y|)))) (CONS |x| |y|))) -(DECLAIM (FTYPE (FUNCTION (|%Thing|) |%List|) |bfCreateDef|)) +(DECLAIM (FTYPE (FUNCTION (|%Thing|) |%Form|) |bfCreateDef|)) (DEFUN |bfCreateDef| (|x|) (PROG (|a| |f|) @@ -2057,24 +2058,24 @@ ((AND (CONSP |x|) (NULL (CDR |x|))) (SETQ |f| (CAR |x|)) (LIST 'DEFCONSTANT |f| (LIST 'LIST (LIST 'QUOTE |f|)))) (T (SETQ |a| - (LET ((|bfVar#127| NIL) (|bfVar#126| (CDR |x|)) + (LET ((|bfVar#126| NIL) (|bfVar#125| (CDR |x|)) (|i| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#126|) - (PROGN (SETQ |i| (CAR |bfVar#126|)) NIL)) - (RETURN (|reverse!| |bfVar#127|))) - (T (SETQ |bfVar#127| - (CONS (|bfGenSymbol|) |bfVar#127|)))) - (SETQ |bfVar#126| (CDR |bfVar#126|))))) + ((OR (ATOM |bfVar#125|) + (PROGN (SETQ |i| (CAR |bfVar#125|)) NIL)) + (RETURN (|reverse!| |bfVar#126|))) + (T (SETQ |bfVar#126| + (CONS (|bfGenSymbol|) |bfVar#126|)))) + (SETQ |bfVar#125| (CDR |bfVar#125|))))) (LIST 'DEFUN (CAR |x|) |a| (LIST 'CONS (LIST 'QUOTE (CAR |x|)) (CONS 'LIST |a|)))))))) -(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing|) |%List|) |bfCaseItem|)) +(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing|) |%Form|) |bfCaseItem|)) (DEFUN |bfCaseItem| (|x| |y|) (LIST |x| |y|)) -(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing|) |%List|) |bfCase|)) +(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing|) |%Form|) |bfCase|)) (DEFUN |bfCase| (|x| |y|) (PROG (|body| |g|) @@ -2088,28 +2089,30 @@ ((EQ |g| |x|) |body|) (T (LIST 'LET (LIST (LIST |g| |x|)) |body|))))))) -(DECLAIM (FTYPE (FUNCTION (|%Thing| |%List|) |%List|) |bfCaseItems|)) +(DECLAIM (FTYPE (FUNCTION (|%Thing| (|%List| |%Form|)) + (|%List| |%Form|)) + |bfCaseItems|)) (DEFUN |bfCaseItems| (|g| |x|) (PROG (|j| |ISTMP#1| |i|) (RETURN - (LET ((|bfVar#130| NIL) (|bfVar#129| |x|) (|bfVar#128| NIL)) + (LET ((|bfVar#129| NIL) (|bfVar#128| |x|) (|bfVar#127| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#129|) - (PROGN (SETQ |bfVar#128| (CAR |bfVar#129|)) NIL)) - (RETURN (|reverse!| |bfVar#130|))) - (T (AND (CONSP |bfVar#128|) + ((OR (ATOM |bfVar#128|) + (PROGN (SETQ |bfVar#127| (CAR |bfVar#128|)) NIL)) + (RETURN (|reverse!| |bfVar#129|))) + (T (AND (CONSP |bfVar#127|) (PROGN - (SETQ |i| (CAR |bfVar#128|)) - (SETQ |ISTMP#1| (CDR |bfVar#128|)) + (SETQ |i| (CAR |bfVar#127|)) + (SETQ |ISTMP#1| (CDR |bfVar#127|)) (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)) (PROGN (SETQ |j| (CAR |ISTMP#1|)) T))) - (SETQ |bfVar#130| - (CONS (|bfCI| |g| |i| |j|) |bfVar#130|))))) - (SETQ |bfVar#129| (CDR |bfVar#129|))))))) + (SETQ |bfVar#129| + (CONS (|bfCI| |g| |i| |j|) |bfVar#129|))))) + (SETQ |bfVar#128| (CDR |bfVar#128|))))))) -(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing| |%Thing|) |%List|) |bfCI|)) +(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing| |%Thing|) |%Form|) |bfCI|)) (DEFUN |bfCI| (|g| |x| |y|) (PROG (|b| |a|) @@ -2119,25 +2122,25 @@ (COND ((NULL |a|) (LIST (CAR |x|) |y|)) (T (SETQ |b| - (LET ((|bfVar#132| NIL) (|bfVar#131| |a|) (|i| NIL) + (LET ((|bfVar#131| NIL) (|bfVar#130| |a|) (|i| NIL) (|j| 1)) (LOOP (COND - ((OR (ATOM |bfVar#131|) - (PROGN (SETQ |i| (CAR |bfVar#131|)) NIL)) - (RETURN (|reverse!| |bfVar#132|))) + ((OR (ATOM |bfVar#130|) + (PROGN (SETQ |i| (CAR |bfVar#130|)) NIL)) + (RETURN (|reverse!| |bfVar#131|))) (T (AND (NOT (EQ |i| 'DOT)) - (SETQ |bfVar#132| + (SETQ |bfVar#131| (CONS (LIST |i| (|bfCARCDR| |j| |g|)) - |bfVar#132|))))) - (SETQ |bfVar#131| (CDR |bfVar#131|)) + |bfVar#131|))))) + (SETQ |bfVar#130| (CDR |bfVar#130|)) (SETQ |j| (+ |j| 1))))) (COND ((NULL |b|) (LIST (CAR |x|) |y|)) (T (LIST (CAR |x|) (LIST 'LET |b| |y|)))))))))) -(DECLAIM (FTYPE (FUNCTION (|%Short| |%Thing|) |%List|) |bfCARCDR|)) +(DECLAIM (FTYPE (FUNCTION (|%Short| |%Thing|) |%Form|) |bfCARCDR|)) (DEFUN |bfCARCDR| (|n| |g|) (LIST (INTERN (CONCAT "CA" (|bfDs| |n|) "R")) |g|)) @@ -2218,7 +2221,8 @@ (|bfHandlers| |g| (LIST 'CDR |g|) |cs|)) (LIST T |g|))))))) -(DECLAIM (FTYPE (FUNCTION (|%Thing| |%List|) |%Thing|) |bfTry|)) +(DECLAIM (FTYPE (FUNCTION (|%Thing| (|%List| |%Form|)) |%Thing|) + |bfTry|)) (DEFUN |bfTry| (|e| |cs|) (PROG (|s| |cs'| |f| |ISTMP#1| |g|) @@ -2268,16 +2272,16 @@ ((ATOM |form|) (COND ((MEMBER |form| |params|) |form|) (T (|quote| |form|)))) (T (CONS 'LIST - (LET ((|bfVar#134| NIL) (|bfVar#133| |form|) (|t| NIL)) + (LET ((|bfVar#133| NIL) (|bfVar#132| |form|) (|t| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#133|) - (PROGN (SETQ |t| (CAR |bfVar#133|)) NIL)) - (RETURN (|reverse!| |bfVar#134|))) - (T (SETQ |bfVar#134| + ((OR (ATOM |bfVar#132|) + (PROGN (SETQ |t| (CAR |bfVar#132|)) NIL)) + (RETURN (|reverse!| |bfVar#133|))) + (T (SETQ |bfVar#133| (CONS (|backquote| |t| |params|) - |bfVar#134|)))) - (SETQ |bfVar#133| (CDR |bfVar#133|)))))))) + |bfVar#133|)))) + (SETQ |bfVar#132| (CDR |bfVar#132|)))))))) (DEFUN |genTypeAlias| (|head| |body|) (PROG (|args| |op|) @@ -2478,47 +2482,47 @@ (RETURN (PROGN (SETQ |argtypes| - (LET ((|bfVar#136| NIL) (|bfVar#135| |s|) (|x| NIL)) + (LET ((|bfVar#135| NIL) (|bfVar#134| |s|) (|x| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#135|) - (PROGN (SETQ |x| (CAR |bfVar#135|)) NIL)) - (RETURN (|reverse!| |bfVar#136|))) - (T (SETQ |bfVar#136| + ((OR (ATOM |bfVar#134|) + (PROGN (SETQ |x| (CAR |bfVar#134|)) NIL)) + (RETURN (|reverse!| |bfVar#135|))) + (T (SETQ |bfVar#135| (CONS (|nativeArgumentType| |x|) - |bfVar#136|)))) - (SETQ |bfVar#135| (CDR |bfVar#135|))))) + |bfVar#135|)))) + (SETQ |bfVar#134| (CDR |bfVar#134|))))) (SETQ |rettype| (|nativeReturnType| |t|)) (COND - ((LET ((|bfVar#138| T) (|bfVar#137| (CONS |t| |s|)) + ((LET ((|bfVar#137| T) (|bfVar#136| (CONS |t| |s|)) (|x| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#137|) - (PROGN (SETQ |x| (CAR |bfVar#137|)) NIL)) - (RETURN |bfVar#138|)) + ((OR (ATOM |bfVar#136|) + (PROGN (SETQ |x| (CAR |bfVar#136|)) NIL)) + (RETURN |bfVar#137|)) (T (PROGN - (SETQ |bfVar#138| (|isSimpleNativeType| |x|)) - (COND ((NOT |bfVar#138|) (RETURN NIL)))))) - (SETQ |bfVar#137| (CDR |bfVar#137|)))) + (SETQ |bfVar#137| (|isSimpleNativeType| |x|)) + (COND ((NOT |bfVar#137|) (RETURN NIL)))))) + (SETQ |bfVar#136| (CDR |bfVar#136|)))) (LIST (LIST 'DEFENTRY |op| |argtypes| (LIST |rettype| (PNAME |op'|))))) (T (SETQ |cop| (CONCAT (PNAME |op'|) "_stub")) (SETQ |cargs| - (LET ((|bfVar#145| NIL) - (|bfVar#144| (- (LENGTH |s|) 1)) (|i| 0)) + (LET ((|bfVar#144| NIL) + (|bfVar#143| (- (LENGTH |s|) 1)) (|i| 0)) (LOOP (COND - ((> |i| |bfVar#144|) - (RETURN (|reverse!| |bfVar#145|))) - (T (SETQ |bfVar#145| + ((> |i| |bfVar#143|) + (RETURN (|reverse!| |bfVar#144|))) + (T (SETQ |bfVar#144| (CONS (|genGCLnativeTranslation,mkCArgName| |i|) - |bfVar#145|)))) + |bfVar#144|)))) (SETQ |i| (+ |i| 1))))) (SETQ |ccode| - (LET ((|bfVar#141| "") - (|bfVar#143| + (LET ((|bfVar#140| "") + (|bfVar#142| (CONS (|genGCLnativeTranslation,gclTypeInC| |t|) (CONS " " @@ -2526,7 +2530,7 @@ (CONS "(" (APPEND (LET - ((|bfVar#139| NIL) (|x| |s|) + ((|bfVar#138| NIL) (|x| |s|) (|a| |cargs|)) (LOOP (COND @@ -2534,13 +2538,13 @@ (ATOM |a|)) (RETURN (|reverse!| - |bfVar#139|))) + |bfVar#138|))) (T - (SETQ |bfVar#139| + (SETQ |bfVar#138| (CONS (|genGCLnativeTranslation,cparm| |x| |a|) - |bfVar#139|)))) + |bfVar#138|)))) (SETQ |x| (CDR |x|)) (SETQ |a| (CDR |a|)))) (CONS ") { " @@ -2553,7 +2557,7 @@ (CONS "(" (APPEND (LET - ((|bfVar#140| NIL) + ((|bfVar#139| NIL) (|x| |s|) (|a| |cargs|)) (LOOP (COND @@ -2561,27 +2565,27 @@ (ATOM |a|)) (RETURN (|reverse!| - |bfVar#140|))) + |bfVar#139|))) (T - (SETQ |bfVar#140| + (SETQ |bfVar#139| (CONS (|genGCLnativeTranslation,gclArgsInC| |x| |a|) - |bfVar#140|)))) + |bfVar#139|)))) (SETQ |x| (CDR |x|)) (SETQ |a| (CDR |a|)))) (CONS "); }" NIL)))))))))))) - (|bfVar#142| NIL)) + (|bfVar#141| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#143|) + ((OR (ATOM |bfVar#142|) (PROGN - (SETQ |bfVar#142| (CAR |bfVar#143|)) + (SETQ |bfVar#141| (CAR |bfVar#142|)) NIL)) - (RETURN |bfVar#141|)) - (T (SETQ |bfVar#141| - (CONCAT |bfVar#141| |bfVar#142|)))) - (SETQ |bfVar#143| (CDR |bfVar#143|))))) + (RETURN |bfVar#140|)) + (T (SETQ |bfVar#140| + (CONCAT |bfVar#140| |bfVar#141|)))) + (SETQ |bfVar#142| (CDR |bfVar#142|))))) (LIST (LIST 'CLINES |ccode|) (LIST 'DEFENTRY |op| |argtypes| (LIST |rettype| |cop|))))))))) @@ -2641,17 +2645,17 @@ (PROGN (SETQ |args| NIL) (SETQ |argtypes| NIL) - (LET ((|bfVar#146| |s|) (|x| NIL)) + (LET ((|bfVar#145| |s|) (|x| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#146|) - (PROGN (SETQ |x| (CAR |bfVar#146|)) NIL)) + ((OR (ATOM |bfVar#145|) + (PROGN (SETQ |x| (CAR |bfVar#145|)) NIL)) (RETURN NIL)) (T (PROGN (SETQ |argtypes| (CONS (|nativeArgumentType| |x|) |argtypes|)) (SETQ |args| (CONS (GENSYM) |args|))))) - (SETQ |bfVar#146| (CDR |bfVar#146|)))) + (SETQ |bfVar#145| (CDR |bfVar#145|)))) (SETQ |args| (|reverse| |args|)) (SETQ |rettype| (|nativeReturnType| |t|)) (LIST (LIST 'DEFUN |op| |args| @@ -2662,40 +2666,40 @@ :ONE-LINER T))))))) (DEFUN |genECLnativeTranslation,callTemplate| (|op| |n| |s|) - (LET ((|bfVar#150| "") - (|bfVar#152| + (LET ((|bfVar#149| "") + (|bfVar#151| (CONS (PNAME |op|) (CONS "(" - (APPEND (LET ((|bfVar#149| NIL) - (|bfVar#147| (- |n| 1)) (|i| 0) - (|bfVar#148| |s|) (|x| NIL)) + (APPEND (LET ((|bfVar#148| NIL) + (|bfVar#146| (- |n| 1)) (|i| 0) + (|bfVar#147| |s|) (|x| NIL)) (LOOP (COND - ((OR (> |i| |bfVar#147|) - (ATOM |bfVar#148|) + ((OR (> |i| |bfVar#146|) + (ATOM |bfVar#147|) (PROGN - (SETQ |x| (CAR |bfVar#148|)) + (SETQ |x| (CAR |bfVar#147|)) NIL)) (RETURN - (|reverse!| |bfVar#149|))) + (|reverse!| |bfVar#148|))) (T - (SETQ |bfVar#149| + (SETQ |bfVar#148| (CONS (|genECLnativeTranslation,sharpArg| |i| |x|) - |bfVar#149|)))) + |bfVar#148|)))) (SETQ |i| (+ |i| 1)) - (SETQ |bfVar#148| - (CDR |bfVar#148|)))) + (SETQ |bfVar#147| + (CDR |bfVar#147|)))) (CONS ")" NIL))))) - (|bfVar#151| NIL)) + (|bfVar#150| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#152|) - (PROGN (SETQ |bfVar#151| (CAR |bfVar#152|)) NIL)) - (RETURN |bfVar#150|)) - (T (SETQ |bfVar#150| (CONCAT |bfVar#150| |bfVar#151|)))) - (SETQ |bfVar#152| (CDR |bfVar#152|))))) + ((OR (ATOM |bfVar#151|) + (PROGN (SETQ |bfVar#150| (CAR |bfVar#151|)) NIL)) + (RETURN |bfVar#149|)) + (T (SETQ |bfVar#149| (CONCAT |bfVar#149| |bfVar#150|)))) + (SETQ |bfVar#151| (CDR |bfVar#151|))))) (DEFUN |genECLnativeTranslation,sharpArg| (|i| |x|) (COND @@ -2735,38 +2739,38 @@ (PROGN (SETQ |rettype| (|nativeReturnType| |t|)) (SETQ |argtypes| - (LET ((|bfVar#154| NIL) (|bfVar#153| |s|) (|x| NIL)) + (LET ((|bfVar#153| NIL) (|bfVar#152| |s|) (|x| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#153|) - (PROGN (SETQ |x| (CAR |bfVar#153|)) NIL)) - (RETURN (|reverse!| |bfVar#154|))) - (T (SETQ |bfVar#154| + ((OR (ATOM |bfVar#152|) + (PROGN (SETQ |x| (CAR |bfVar#152|)) NIL)) + (RETURN (|reverse!| |bfVar#153|))) + (T (SETQ |bfVar#153| (CONS (|nativeArgumentType| |x|) - |bfVar#154|)))) - (SETQ |bfVar#153| (CDR |bfVar#153|))))) + |bfVar#153|)))) + (SETQ |bfVar#152| (CDR |bfVar#152|))))) (SETQ |n| (INTERN (CONCAT (PNAME |op|) "%clisp-hack"))) (SETQ |parms| - (LET ((|bfVar#156| NIL) (|bfVar#155| |s|) (|x| NIL)) + (LET ((|bfVar#155| NIL) (|bfVar#154| |s|) (|x| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#155|) - (PROGN (SETQ |x| (CAR |bfVar#155|)) NIL)) - (RETURN (|reverse!| |bfVar#156|))) - (T (SETQ |bfVar#156| - (CONS (GENSYM "parm") |bfVar#156|)))) - (SETQ |bfVar#155| (CDR |bfVar#155|))))) + ((OR (ATOM |bfVar#154|) + (PROGN (SETQ |x| (CAR |bfVar#154|)) NIL)) + (RETURN (|reverse!| |bfVar#155|))) + (T (SETQ |bfVar#155| + (CONS (GENSYM "parm") |bfVar#155|)))) + (SETQ |bfVar#154| (CDR |bfVar#154|))))) (SETQ |unstableArgs| NIL) - (LET ((|bfVar#157| |parms|) (|p| NIL) (|bfVar#158| |s|) - (|x| NIL) (|bfVar#159| |argtypes|) (|y| NIL)) + (LET ((|bfVar#156| |parms|) (|p| NIL) (|bfVar#157| |s|) + (|x| NIL) (|bfVar#158| |argtypes|) (|y| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#157|) - (PROGN (SETQ |p| (CAR |bfVar#157|)) NIL) + ((OR (ATOM |bfVar#156|) + (PROGN (SETQ |p| (CAR |bfVar#156|)) NIL) + (ATOM |bfVar#157|) + (PROGN (SETQ |x| (CAR |bfVar#157|)) NIL) (ATOM |bfVar#158|) - (PROGN (SETQ |x| (CAR |bfVar#158|)) NIL) - (ATOM |bfVar#159|) - (PROGN (SETQ |y| (CAR |bfVar#159|)) NIL)) + (PROGN (SETQ |y| (CAR |bfVar#158|)) NIL)) (RETURN NIL)) (T (COND ((|needsStableReference?| |x|) @@ -2774,31 +2778,31 @@ (SETQ |unstableArgs| (CONS (CONS |p| (CONS |x| |y|)) |unstableArgs|))))))) + (SETQ |bfVar#156| (CDR |bfVar#156|)) (SETQ |bfVar#157| (CDR |bfVar#157|)) - (SETQ |bfVar#158| (CDR |bfVar#158|)) - (SETQ |bfVar#159| (CDR |bfVar#159|)))) + (SETQ |bfVar#158| (CDR |bfVar#158|)))) (SETQ |foreignDecl| (LIST (|bfColonColon| 'FFI 'DEF-CALL-OUT) |n| (LIST :NAME (PNAME |op'|)) (CONS :ARGUMENTS - (LET ((|bfVar#162| NIL) - (|bfVar#160| |argtypes|) (|x| NIL) - (|bfVar#161| |parms|) (|a| NIL)) + (LET ((|bfVar#161| NIL) + (|bfVar#159| |argtypes|) (|x| NIL) + (|bfVar#160| |parms|) (|a| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#160|) + ((OR (ATOM |bfVar#159|) (PROGN - (SETQ |x| (CAR |bfVar#160|)) + (SETQ |x| (CAR |bfVar#159|)) NIL) - (ATOM |bfVar#161|) + (ATOM |bfVar#160|) (PROGN - (SETQ |a| (CAR |bfVar#161|)) + (SETQ |a| (CAR |bfVar#160|)) NIL)) - (RETURN (|reverse!| |bfVar#162|))) - (T (SETQ |bfVar#162| - (CONS (LIST |a| |x|) |bfVar#162|)))) - (SETQ |bfVar#160| (CDR |bfVar#160|)) - (SETQ |bfVar#161| (CDR |bfVar#161|))))) + (RETURN (|reverse!| |bfVar#161|))) + (T (SETQ |bfVar#161| + (CONS (LIST |a| |x|) |bfVar#161|)))) + (SETQ |bfVar#159| (CDR |bfVar#159|)) + (SETQ |bfVar#160| (CDR |bfVar#160|))))) (LIST :RETURN-TYPE |rettype|) (LIST :LANGUAGE :STDC))) (SETQ |forwardingFun| @@ -2806,67 +2810,67 @@ ((NULL |unstableArgs|) (LIST 'DEFUN |op| |parms| (CONS |n| |parms|))) (T (SETQ |localPairs| - (LET ((|bfVar#165| NIL) - (|bfVar#164| |unstableArgs|) - (|bfVar#163| NIL)) + (LET ((|bfVar#164| NIL) + (|bfVar#163| |unstableArgs|) + (|bfVar#162| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#164|) + ((OR (ATOM |bfVar#163|) (PROGN - (SETQ |bfVar#163| - (CAR |bfVar#164|)) + (SETQ |bfVar#162| + (CAR |bfVar#163|)) NIL)) - (RETURN (|reverse!| |bfVar#165|))) - (T (AND (CONSP |bfVar#163|) + (RETURN (|reverse!| |bfVar#164|))) + (T (AND (CONSP |bfVar#162|) (PROGN - (SETQ |a| (CAR |bfVar#163|)) + (SETQ |a| (CAR |bfVar#162|)) (SETQ |ISTMP#1| - (CDR |bfVar#163|)) + (CDR |bfVar#162|)) (AND (CONSP |ISTMP#1|) (PROGN (SETQ |x| (CAR |ISTMP#1|)) (SETQ |y| (CDR |ISTMP#1|)) T))) - (SETQ |bfVar#165| + (SETQ |bfVar#164| (CONS (CONS |a| (CONS |x| (CONS |y| (GENSYM "loc")))) - |bfVar#165|))))) - (SETQ |bfVar#164| (CDR |bfVar#164|))))) + |bfVar#164|))))) + (SETQ |bfVar#163| (CDR |bfVar#163|))))) (SETQ |call| (CONS |n| - (LET ((|bfVar#167| NIL) - (|bfVar#166| |parms|) (|p| NIL)) + (LET ((|bfVar#166| NIL) + (|bfVar#165| |parms|) (|p| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#166|) + ((OR (ATOM |bfVar#165|) (PROGN - (SETQ |p| (CAR |bfVar#166|)) + (SETQ |p| (CAR |bfVar#165|)) NIL)) (RETURN - (|reverse!| |bfVar#167|))) + (|reverse!| |bfVar#166|))) (T - (SETQ |bfVar#167| + (SETQ |bfVar#166| (CONS (|genCLISPnativeTranslation,actualArg| |p| |localPairs|) - |bfVar#167|)))) - (SETQ |bfVar#166| (CDR |bfVar#166|)))))) + |bfVar#166|)))) + (SETQ |bfVar#165| (CDR |bfVar#165|)))))) (SETQ |call| (PROGN (SETQ |fixups| - (LET ((|bfVar#169| NIL) - (|bfVar#168| |localPairs|) + (LET ((|bfVar#168| NIL) + (|bfVar#167| |localPairs|) (|p| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#168|) + ((OR (ATOM |bfVar#167|) (PROGN - (SETQ |p| (CAR |bfVar#168|)) + (SETQ |p| (CAR |bfVar#167|)) NIL)) (RETURN - (|reverse!| |bfVar#169|))) + (|reverse!| |bfVar#168|))) (T (AND (NOT @@ -2874,26 +2878,26 @@ (SETQ |q| (|genCLISPnativeTranslation,copyBack| |p|)))) - (SETQ |bfVar#169| - (CONS |q| |bfVar#169|))))) - (SETQ |bfVar#168| - (CDR |bfVar#168|))))) + (SETQ |bfVar#168| + (CONS |q| |bfVar#168|))))) + (SETQ |bfVar#167| + (CDR |bfVar#167|))))) (COND ((NULL |fixups|) (LIST |call|)) (T (LIST (CONS 'PROG1 (CONS |call| |fixups|))))))) - (LET ((|bfVar#171| |localPairs|) (|bfVar#170| NIL)) + (LET ((|bfVar#170| |localPairs|) (|bfVar#169| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#171|) + ((OR (ATOM |bfVar#170|) (PROGN - (SETQ |bfVar#170| (CAR |bfVar#171|)) + (SETQ |bfVar#169| (CAR |bfVar#170|)) NIL)) (RETURN NIL)) - (T (AND (CONSP |bfVar#170|) + (T (AND (CONSP |bfVar#169|) (PROGN - (SETQ |p| (CAR |bfVar#170|)) - (SETQ |ISTMP#1| (CDR |bfVar#170|)) + (SETQ |p| (CAR |bfVar#169|)) + (SETQ |ISTMP#1| (CDR |bfVar#169|)) (AND (CONSP |ISTMP#1|) (PROGN (SETQ |x| (CAR |ISTMP#1|)) @@ -2916,18 +2920,18 @@ |p|) |p|) |call|))))))) - (SETQ |bfVar#171| (CDR |bfVar#171|)))) + (SETQ |bfVar#170| (CDR |bfVar#170|)))) (CONS 'DEFUN (CONS |op| (CONS |parms| |call|)))))) (SETQ |$foreignsDefsForCLisp| (CONS |foreignDecl| |$foreignsDefsForCLisp|)) (LIST |forwardingFun|))))) -(DEFUN |genCLISPnativeTranslation,copyBack| (|bfVar#172|) +(DEFUN |genCLISPnativeTranslation,copyBack| (|bfVar#171|) (PROG (|a| |y| |x| |p|) (RETURN (PROGN - (SETQ |p| (CAR |bfVar#172|)) - (SETQ |x| (CADR . #0=(|bfVar#172|))) + (SETQ |p| (CAR |bfVar#171|)) + (SETQ |x| (CADR . #0=(|bfVar#171|))) (SETQ |y| (CADDR . #0#)) (SETQ |a| (CDDDR . #0#)) (COND @@ -2951,35 +2955,35 @@ (PROGN (SETQ |rettype| (|nativeReturnType| |t|)) (SETQ |argtypes| - (LET ((|bfVar#174| NIL) (|bfVar#173| |s|) (|x| NIL)) + (LET ((|bfVar#173| NIL) (|bfVar#172| |s|) (|x| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#173|) - (PROGN (SETQ |x| (CAR |bfVar#173|)) NIL)) - (RETURN (|reverse!| |bfVar#174|))) - (T (SETQ |bfVar#174| + ((OR (ATOM |bfVar#172|) + (PROGN (SETQ |x| (CAR |bfVar#172|)) NIL)) + (RETURN (|reverse!| |bfVar#173|))) + (T (SETQ |bfVar#173| (CONS (|nativeArgumentType| |x|) - |bfVar#174|)))) - (SETQ |bfVar#173| (CDR |bfVar#173|))))) + |bfVar#173|)))) + (SETQ |bfVar#172| (CDR |bfVar#172|))))) (SETQ |args| - (LET ((|bfVar#176| NIL) (|bfVar#175| |s|) (|x| NIL)) + (LET ((|bfVar#175| NIL) (|bfVar#174| |s|) (|x| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#175|) - (PROGN (SETQ |x| (CAR |bfVar#175|)) NIL)) - (RETURN (|reverse!| |bfVar#176|))) - (T (SETQ |bfVar#176| (CONS (GENSYM) |bfVar#176|)))) - (SETQ |bfVar#175| (CDR |bfVar#175|))))) + ((OR (ATOM |bfVar#174|) + (PROGN (SETQ |x| (CAR |bfVar#174|)) NIL)) + (RETURN (|reverse!| |bfVar#175|))) + (T (SETQ |bfVar#175| (CONS (GENSYM) |bfVar#175|)))) + (SETQ |bfVar#174| (CDR |bfVar#174|))))) (SETQ |unstableArgs| NIL) (SETQ |newArgs| NIL) - (LET ((|bfVar#177| |args|) (|a| NIL) (|bfVar#178| |s|) + (LET ((|bfVar#176| |args|) (|a| NIL) (|bfVar#177| |s|) (|x| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#177|) - (PROGN (SETQ |a| (CAR |bfVar#177|)) NIL) - (ATOM |bfVar#178|) - (PROGN (SETQ |x| (CAR |bfVar#178|)) NIL)) + ((OR (ATOM |bfVar#176|) + (PROGN (SETQ |a| (CAR |bfVar#176|)) NIL) + (ATOM |bfVar#177|) + (PROGN (SETQ |x| (CAR |bfVar#177|)) NIL)) (RETURN NIL)) (T (PROGN (SETQ |newArgs| @@ -2988,8 +2992,8 @@ (COND ((|needsStableReference?| |x|) (SETQ |unstableArgs| (CONS |a| |unstableArgs|))))))) - (SETQ |bfVar#177| (CDR |bfVar#177|)) - (SETQ |bfVar#178| (CDR |bfVar#178|)))) + (SETQ |bfVar#176| (CDR |bfVar#176|)) + (SETQ |bfVar#177| (CDR |bfVar#177|)))) (SETQ |op'| (COND ((|%hasFeature| :WIN32) (CONCAT "_" (PNAME |op'|))) @@ -3026,36 +3030,36 @@ (PROGN (SETQ |rettype| (|nativeReturnType| |t|)) (SETQ |argtypes| - (LET ((|bfVar#180| NIL) (|bfVar#179| |s|) (|x| NIL)) + (LET ((|bfVar#179| NIL) (|bfVar#178| |s|) (|x| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#179|) - (PROGN (SETQ |x| (CAR |bfVar#179|)) NIL)) - (RETURN (|reverse!| |bfVar#180|))) - (T (SETQ |bfVar#180| + ((OR (ATOM |bfVar#178|) + (PROGN (SETQ |x| (CAR |bfVar#178|)) NIL)) + (RETURN (|reverse!| |bfVar#179|))) + (T (SETQ |bfVar#179| (CONS (|nativeArgumentType| |x|) - |bfVar#180|)))) - (SETQ |bfVar#179| (CDR |bfVar#179|))))) + |bfVar#179|)))) + (SETQ |bfVar#178| (CDR |bfVar#178|))))) (SETQ |parms| - (LET ((|bfVar#182| NIL) (|bfVar#181| |s|) (|x| NIL)) + (LET ((|bfVar#181| NIL) (|bfVar#180| |s|) (|x| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#181|) - (PROGN (SETQ |x| (CAR |bfVar#181|)) NIL)) - (RETURN (|reverse!| |bfVar#182|))) - (T (SETQ |bfVar#182| - (CONS (GENSYM "parm") |bfVar#182|)))) - (SETQ |bfVar#181| (CDR |bfVar#181|))))) + ((OR (ATOM |bfVar#180|) + (PROGN (SETQ |x| (CAR |bfVar#180|)) NIL)) + (RETURN (|reverse!| |bfVar#181|))) + (T (SETQ |bfVar#181| + (CONS (GENSYM "parm") |bfVar#181|)))) + (SETQ |bfVar#180| (CDR |bfVar#180|))))) (SETQ |strPairs| NIL) (SETQ |aryPairs| NIL) - (LET ((|bfVar#183| |parms|) (|p| NIL) (|bfVar#184| |s|) + (LET ((|bfVar#182| |parms|) (|p| NIL) (|bfVar#183| |s|) (|x| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#183|) - (PROGN (SETQ |p| (CAR |bfVar#183|)) NIL) - (ATOM |bfVar#184|) - (PROGN (SETQ |x| (CAR |bfVar#184|)) NIL)) + ((OR (ATOM |bfVar#182|) + (PROGN (SETQ |p| (CAR |bfVar#182|)) NIL) + (ATOM |bfVar#183|) + (PROGN (SETQ |x| (CAR |bfVar#183|)) NIL)) (RETURN NIL)) (T (COND ((EQ |x| '|string|) @@ -3077,33 +3081,33 @@ (NULL (CDR |ISTMP#3|))))))))) (SETQ |aryPairs| (CONS (CONS |p| (GENSYM "loc")) |aryPairs|)))))) - (SETQ |bfVar#183| (CDR |bfVar#183|)) - (SETQ |bfVar#184| (CDR |bfVar#184|)))) + (SETQ |bfVar#182| (CDR |bfVar#182|)) + (SETQ |bfVar#183| (CDR |bfVar#183|)))) (COND ((|%hasFeature| :DARWIN) (SETQ |op'| (CONCAT '_ |op'|)))) (SETQ |call| (CONS (|bfColonColon| 'CCL 'EXTERNAL-CALL) (CONS (STRING |op'|) - (APPEND (LET ((|bfVar#187| NIL) - (|bfVar#185| |argtypes|) - (|x| NIL) (|bfVar#186| |parms|) + (APPEND (LET ((|bfVar#186| NIL) + (|bfVar#184| |argtypes|) + (|x| NIL) (|bfVar#185| |parms|) (|p| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#185|) + ((OR (ATOM |bfVar#184|) (PROGN (SETQ |x| - (CAR |bfVar#185|)) + (CAR |bfVar#184|)) NIL) - (ATOM |bfVar#186|) + (ATOM |bfVar#185|) (PROGN (SETQ |p| - (CAR |bfVar#186|)) + (CAR |bfVar#185|)) NIL)) (RETURN - (|reverse!| |bfVar#187|))) + (|reverse!| |bfVar#186|))) (T - (SETQ |bfVar#187| + (SETQ |bfVar#186| (APPEND (|reverse| (LIST |x| @@ -3115,45 +3119,45 @@ (ASSOC |p| |aryPairs|)) (CDR |p'|)) (T |p|)))) - |bfVar#187|)))) + |bfVar#186|)))) + (SETQ |bfVar#184| + (CDR |bfVar#184|)) (SETQ |bfVar#185| - (CDR |bfVar#185|)) - (SETQ |bfVar#186| - (CDR |bfVar#186|)))) + (CDR |bfVar#185|)))) (CONS |rettype| NIL))))) (COND ((EQ |t| '|string|) (SETQ |call| (LIST (|bfColonColon| 'CCL 'GET-CSTRING) |call|)))) - (LET ((|bfVar#188| |aryPairs|) (|arg| NIL)) + (LET ((|bfVar#187| |aryPairs|) (|arg| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#188|) - (PROGN (SETQ |arg| (CAR |bfVar#188|)) NIL)) + ((OR (ATOM |bfVar#187|) + (PROGN (SETQ |arg| (CAR |bfVar#187|)) NIL)) (RETURN NIL)) (T (SETQ |call| (LIST (|bfColonColon| 'CCL 'WITH-POINTER-TO-IVECTOR) (LIST (CDR |arg|) (CAR |arg|)) |call|)))) - (SETQ |bfVar#188| (CDR |bfVar#188|)))) + (SETQ |bfVar#187| (CDR |bfVar#187|)))) (COND (|strPairs| (SETQ |call| (LIST (|bfColonColon| 'CCL 'WITH-CSTRS) - (LET ((|bfVar#190| NIL) - (|bfVar#189| |strPairs|) (|arg| NIL)) + (LET ((|bfVar#189| NIL) + (|bfVar#188| |strPairs|) (|arg| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#189|) + ((OR (ATOM |bfVar#188|) (PROGN - (SETQ |arg| (CAR |bfVar#189|)) + (SETQ |arg| (CAR |bfVar#188|)) NIL)) - (RETURN (|reverse!| |bfVar#190|))) - (T (SETQ |bfVar#190| + (RETURN (|reverse!| |bfVar#189|))) + (T (SETQ |bfVar#189| (CONS (LIST (CDR |arg|) (CAR |arg|)) - |bfVar#190|)))) - (SETQ |bfVar#189| (CDR |bfVar#189|)))) + |bfVar#189|)))) + (SETQ |bfVar#188| (CDR |bfVar#188|)))) |call|)))) (LIST (LIST 'DEFUN |op| |parms| |call|)))))) diff --git a/src/boot/strap/parser.clisp b/src/boot/strap/parser.clisp index a8a0b811..80aa2a76 100644 --- a/src/boot/strap/parser.clisp +++ b/src/boot/strap/parser.clisp @@ -506,24 +506,23 @@ (|bpLogical|) (|bpPush| (|%TypeAlias| (|bpPop2|) (|bpPop1|))))) (DEFUN |bpSignature| () - (AND (|bpName|) (|bpEqKey| 'COLON) (|bpMapping|) + (AND (|bpName|) (|bpEqKey| 'COLON) (|bpTyping|) (|bpPush| (|%Signature| (|bpPop2|) (|bpPop1|))))) (DEFUN |bpSimpleMapping| () (COND ((|bpApplication|) (AND (|bpEqKey| 'ARROW) (OR (|bpApplication|) (|bpTrap|)) - (|bpPush| (|%Mapping| (|bpPop1|) (|bfUntuple| (|bpPop1|))))) + (|bpPush| (|%Mapping| (|bpPop1|) (LIST (|bpPop1|))))) T) (T NIL))) (DEFUN |bpArgtypeList| () (|bpTuple| #'|bpApplication|)) (DEFUN |bpMapping| () - (OR (AND (|bpParenthesized| #'|bpArgtypeList|) (|bpEqKey| 'ARROW) - (|bpApplication|) - (|bpPush| (|%Mapping| (|bpPop1|) (|bfUntuple| (|bpPop1|))))) - (|bpSimpleMapping|))) + (AND (|bpParenthesized| #'|bpArgtypeList|) (|bpEqKey| 'ARROW) + (|bpApplication|) + (|bpPush| (|%Mapping| (|bpPop1|) (|bfUntuple| (|bpPop1|)))))) (DEFUN |bpCancel| () (PROG (|a|) @@ -633,15 +632,7 @@ (|bpPush| (|bfApplication| (|bpPop2|) (|bpPop1|)))) T))) -(DEFUN |bpTyping| () - (OR (AND (|bpApplication|) - (OR (AND (|bpEqKey| 'ARROW) - (OR (|bpApplication|) (|bpTrap|)) - (|bpPush| - (|%Mapping| (|bpPop1|) - (|bfUntuple| (|bpPop1|))))) - T)) - (|bpMapping|))) +(DEFUN |bpTyping| () (OR (|bpMapping|) (|bpSimpleMapping|))) (DEFUN |bpTagged| () (AND (|bpApplication|) @@ -852,8 +843,10 @@ (DEFUN |bpUntil| () (|bpAndOr| 'UNTIL #'|bpLogical| #'|bfUntil|)) +(DEFUN |bpFormal| () (OR (|bpVariable|) (|bpDot|))) + (DEFUN |bpForIn| () - (AND (|bpEqKey| 'FOR) (OR (|bpVariable|) (|bpTrap|)) + (AND (|bpEqKey| 'FOR) (OR (|bpFormal|) (|bpTrap|)) (|bpCompMissing| 'IN) (OR (AND (OR (|bpSeg|) (|bpTrap|)) (|bpEqKey| 'BY) (OR (|bpArith|) (|bpTrap|)) diff --git a/src/interp/astr.boot b/src/interp/astr.boot index 32f656fb..9597e934 100644 --- a/src/interp/astr.boot +++ b/src/interp/astr.boot @@ -35,9 +35,9 @@ import vmlisp namespace BOOT module astr where ncTag: %Thing -> %Symbol - ncAlist: %Thing -> %List - ncEltQ: (%List,%Thing) -> %Thing - ncPutQ: (%List,%Thing,%Thing) -> %Thing + ncAlist: %Thing -> %List %Thing + ncEltQ: (%List %Thing,%Thing) -> %Thing + ncPutQ: (%List %Thing,%Thing,%Thing) -> %Thing --% Attributed Structures (astr) -- For objects which are pairs where the first field is either just a tag diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot index 619555d0..9cd39a91 100644 --- a/src/interp/c-util.boot +++ b/src/interp/c-util.boot @@ -39,7 +39,7 @@ namespace BOOT module c_-util where clearReplacement: %Symbol -> %Thing replaceSimpleFunctions: %Form -> %Form - foldExportedFunctionReferences: %List -> %List + foldExportedFunctionReferences: %List %Form -> %List %Form diagnoseUnknownType: (%Mode,%Env) -> %Form declareUnusedParameters: %Code -> %Code registerFunctionReplacement: (%Symbol,%Form) -> %Thing @@ -143,7 +143,7 @@ isTupleInstance t == ++ Returns true if the signature `sig' describes a function that can ++ accept a homogeneous variable length argument list. -isHomoegenousVarargSignature: %Signature -> %Boolean +isHomoegenousVarargSignature: %Sig -> %Boolean isHomoegenousVarargSignature sig == #sig = 1 and isTupleInstance first sig @@ -151,13 +151,13 @@ isHomoegenousVarargSignature sig == ++ parameter type list `sig'. This means that either the number ++ of arguments is exactly the number of parameters, or that the ++ signature describes a homogeneous vararg operation. -enoughArguments: (%List,%Signature) -> %Boolean +enoughArguments: (%List %Form,%Sig) -> %Boolean enoughArguments(args,sig) == #args = #sig or isHomoegenousVarargSignature sig ++ Returns true if the operation described by the signature `sig' ++ wants its arguments as a Tuple object. -wantArgumentsAsTuple: (%List,%Signature) -> %Boolean +wantArgumentsAsTuple: (%List %Form,%Sig) -> %Boolean wantArgumentsAsTuple(args,sig) == isHomoegenousVarargSignature sig and #args ~= #sig @@ -1129,11 +1129,11 @@ clearReplacement name == registerFunctionReplacement(name,body) == LAM_,EVALANDFILEACTQ ["PUT",MKQ name,MKQ "SPADreplace",quoteMinimally body] -eqSubstAndCopy: (%List, %List, %Form) -> %Form +eqSubstAndCopy: (%List %Form, %List %Symbol, %Form) -> %Form eqSubstAndCopy(args,parms,body) == SUBLIS(pairList(parms,args),body,KEYWORD::TEST,function EQ) -eqSubst: (%List, %List, %Form) -> %Form +eqSubst: (%List %Form, %List %Symbol, %Form) -> %Form eqSubst(args,parms,body) == NSUBLIS(pairList(parms,args),body,KEYWORD::TEST,function EQ) @@ -1319,7 +1319,7 @@ proclaimCapsuleFunction(op,sig) == [first d, :[normalize(first args,false) for args in tails rest d]] ++ Lisp back end compiler for ILAM with `name', formal `args', and `body'. -backendCompileILAM: (%Symbol,%List, %Code) -> %Symbol +backendCompileILAM: (%Symbol,%List %Symbol, %Code) -> %Symbol backendCompileILAM(name,args,body) == args' := NLIST(#args, ["GENSYM"]) body' := eqSubst(args',args,body) @@ -1351,7 +1351,7 @@ backendCompileNEWNAM x == ++ its values are cached, so that equal lists of argument values ++ yield equal values. The arguments-value pairs are stored ++ as alists. -backendCompileSLAM: (%Symbol,%List,%Code) -> %Symbol +backendCompileSLAM: (%Symbol,%List %Symbol,%Code) -> %Symbol backendCompileSLAM(name,args,body) == al := mkCacheName name -- name of the cache alist. auxfn := INTERNL(name,'";") -- name of the worker function. @@ -1383,7 +1383,7 @@ backendCompileSLAM(name,args,body) == ++ Same as backendCompileSLAM, except that the cache is a hash ++ table. This backend compiler is used to compile constructors. -backendCompileSPADSLAM: (%Symbol,%List,%Code) -> %Symbol +backendCompileSPADSLAM: (%Symbol,%List %Symbol,%Code) -> %Symbol backendCompileSPADSLAM(name,args,body) == al := mkCacheName name -- name of the cache hash table. auxfn := INTERNL(name,'";") -- name of the worker function. @@ -1450,7 +1450,7 @@ $SpecialVars := [] ++ push `x' into the list of local variables. -pushLocalVariable: %Symbol -> %List +pushLocalVariable: %Symbol -> %List %Symbol pushLocalVariable x == p := symbolName x x ~= "$" and stringChar(p,0) = char "$" and @@ -1519,21 +1519,21 @@ massageBackendCode x == massageBackendCode rest x -skipDeclarations: %List -> %List +skipDeclarations: %List %Code -> %List %Code skipDeclarations form == while first form is ["DECLARE",:.] repeat form := rest form form ++ return the last node containing a declaration in form, otherwise nil. -lastDeclarationNode: %List -> %List +lastDeclarationNode: %List %Code -> %List %Code lastDeclarationNode form == while second form is ["DECLARE",:.] repeat form := rest form first form is ["DECLARE",:.] => form nil -declareGlobalVariables: %List -> %List +declareGlobalVariables: %List %Symbol -> %Code declareGlobalVariables vars == ["DECLARE",["SPECIAL",:vars]] diff --git a/src/interp/category.boot b/src/interp/category.boot index c562a43c..07447181 100644 --- a/src/interp/category.boot +++ b/src/interp/category.boot @@ -82,12 +82,12 @@ CategoryPrint(D,$e) == atom first u => SAY("Alternate View corresponding to: ",u) PRETTYPRINT u -++ Returns a fresly built category object for a domain or package +++ Returns a freshly built category object for a domain or package ++ (as indicated by `domainOrPackage'), with signature list ++ designated by `sigList', attribute list designated by `attList', ++ used domains list designated by `domList', and a princical ancestor ++ category object designated by `PrincipalAncestor'. -mkCategory: (%Symbol,%List,%List,%List, %Maybe %Shell) -> %Shell +mkCategory: (%ConstructorKind,%List %Sig,%List %Form,%List %Instantiation, %Maybe %Shell) -> %Shell mkCategory(domainOrPackage,sigList,attList,domList,PrincipalAncestor) == NSigList := nil -- Unless extending a principal ancestor (from the end), start @@ -102,10 +102,12 @@ mkCategory(domainOrPackage,sigList,attList,domList,PrincipalAncestor) == -- ??? Should we not check for predicate subsumption too? or/[x is [[ =sig,.,:impl],:num] for x in NSigList] => [sig,pred,:impl] --only needed for multiple copies of sig - num:= if domainOrPackage="domain" then count else count-5 - nsig:= mkOperatorEntry(sig,pred,num) - NSigList:= [[nsig,:count],:NSigList] - count:= count+1 + num := + domainOrPackage is "domain" => count + count-5 + nsig := mkOperatorEntry(sig,pred,num) + NSigList := [[nsig,:count],:NSigList] + count := count+1 nsig else s for s in sigList] NewLocals:= nil @@ -361,7 +363,7 @@ CatEval x == -- --remove the slot pointers -- [x for x in l | not AncestorP(x.0,leaves)] -AncestorP: (%Form, %List) -> %Form +AncestorP: (%Form, %List %Instantiation) -> %Form AncestorP(xname,leaves) == -- checks for being a principal ancestor of one of the leaves listMember?(xname,leaves) => xname diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot index df6c4848..60d1e521 100644 --- a/src/interp/compiler.boot +++ b/src/interp/compiler.boot @@ -44,13 +44,13 @@ module compiler where comp: (%Form,%Mode,%Env) -> %Maybe %Triple compOrCroak: (%Form,%Mode,%Env) -> %Maybe %Triple compCompilerPredicate: (%Form,%Env) -> %Maybe %Triple - checkCallingConvention: (%List,%Short) -> %SimpleArray %Short + checkCallingConvention: (%List %Sig,%Short) -> %SimpleArray %Short --% compUniquely: (%Form,%Mode,%Env) -> %Maybe %Triple compNoStacking: (%Form,%Mode,%Env) -> %Maybe %Triple -compNoStacking1: (%Form,%Mode,%Env,%List) -> %Maybe %Triple +compNoStacking1: (%Form,%Mode,%Env,%List %Thing) -> %Maybe %Triple compOrCroak1: (%Form,%Mode,%Env,%Thing) -> %Maybe %Triple comp2: (%Form,%Mode,%Env) -> %Maybe %Triple comp3: (%Form,%Mode,%Env) -> %Maybe %Triple @@ -60,22 +60,22 @@ compSymbol: (%Form,%Mode,%Env) -> %Maybe %Triple compTypeOf: (%Form,%Mode,%Env) -> %Maybe %Triple compForm: (%Form,%Mode,%Env) -> %Maybe %Triple compForm1: (%Form,%Mode,%Env) -> %Maybe %Triple -compForm2: (%Form,%Mode,%Env,%List) -> %Maybe %Triple -compForm3: (%Form,%Mode,%Env,%List) -> %Maybe %Triple +compForm2: (%Form,%Mode,%Env,%List %Modemap) -> %Maybe %Triple +compForm3: (%Form,%Mode,%Env,%List %Modemap) -> %Maybe %Triple compArgumentsAndTryAgain: (%Form,%Mode,%Env) -> %Maybe %Triple -compWithMappingMode: (%Form,%Mode,%List) -> %List -compFormMatch: (%Modemap,%List) -> %Boolean +compWithMappingMode: (%Form,%Mode,%Env) -> %Maybe %Triple +compFormMatch: (%Modemap,%List %Mode) -> %Boolean compFormWithModemap: (%Form,%Mode,%Env,%Modemap) -> %Maybe %Triple -compToApply: (%Form,%List,%Mode,%Env) -> %Maybe %Triple -compApplication: (%Form,%List,%Mode,%Triple) -> %Maybe %Triple +compToApply: (%Form,%List %Form,%Mode,%Env) -> %Maybe %Triple +compApplication: (%Form,%List %Form,%Mode,%Triple) -> %Maybe %Triple -primitiveType: %Thing -> %Mode +primitiveType: %Form -> %Mode modeEqual: (%Form,%Form) -> %Boolean hasUniqueCaseView: (%Form,%Mode,%Env) -> %Boolean convertOrCroak: (%Triple,%Mode) -> %Maybe %Triple -getFormModemaps: (%Form,%Env) -> %List -reshapeArgumentList: (%Form,%Signature) -> %Form -applyMapping: (%Form,%Mode,%Env,%List) -> %Maybe %Triple +getFormModemaps: (%Form,%Env) -> %List %Modemap +reshapeArgumentList: (%Form,%Sig) -> %Form +applyMapping: (%Form,%Mode,%Env,%List %Mode) -> %Maybe %Triple ++ A list of routines for diagnostic reports. These functions, in an @@ -208,7 +208,7 @@ compTypeOf(x:=[op,:argl],m,e) == ++ We just determined that `op' is called with argument list `args', where ++ `op' is either a local capsule function, or an external function ++ with a local signature-import declaration. Emit insn for the call. -emitLocalCallInsn: (%Symbol,%List,%Env) -> %Code +emitLocalCallInsn: (%Symbol,%List %Code,%Env) -> %Code emitLocalCallInsn(op,args,e) == op' := -- Find out the linkage name for `op'. get(op,"%Link",e) or encodeLocalFunctionName op @@ -382,7 +382,7 @@ compExpression(x,m,e) == ++ Subroutine of compAtom. ++ Elaborate use of an overloaded constant. -compAtomWithModemap: (%Symbol,%Mode,%Env,%List) -> %Maybe %Triple +compAtomWithModemap: (%Symbol,%Mode,%Env,%List %Modemap) -> %Maybe %Triple compAtomWithModemap(x,m,e,mmList) == -- 1. Get out of here f `x' cannot possibly be a constant. mmList := [mm for mm in mmList | mm.mmImplementation is ['CONST,:.]] @@ -772,8 +772,8 @@ compCons1(["CONS",x,y],m,e) == --% SETQ -compSetq: (%List,%Thing,%List) -> %List -compSetq1: (%Form,%Thing,%Mode,%List) -> %List +compSetq: (%Instantiation,%Mode,%Env) -> %Maybe %Triple +compSetq1: (%Form,%Form,%Mode,%Env) -> %Maybe %Triple compSetq(["%LET",form,val],m,E) == compSetq1(form,val,m,E) @@ -901,7 +901,7 @@ setqMultipleExplicit(nameList,valList,m,e) == ++ ??? based on the meta operator, e.g. (DEF ...) would be a ++ DefinitionAst, etc. That however requires that we have a full ++ fledged AST algebra -- which we don't have yet in mainstream. -compileQuasiquote: (%List,%Thing,%List) -> %List +compileQuasiquote: (%Instantiation,%Mode,%Env) -> %Maybe %Triple compileQuasiquote(["[||]",:form],m,e) == null form => nil coerce([["QUOTE", :form],$Syntax,e], m) @@ -1012,8 +1012,8 @@ compMacro(form,m,e) == --% SEQ compSeq: (%Form,%Mode,%Env) -> %Maybe %Triple -compSeq1: (%Form,%List,%Env) -> %Maybe %Triple -compSeqItem: (%Thing,%Thing,%List) -> %List +compSeq1: (%Form,%List %Thing,%Env) -> %Maybe %Triple +compSeqItem: (%Form,%Mode,%Env) -> %Maybe %Triple compSeq(["SEQ",:l],m,e) == compSeq1(l,[m,:$exitModeStack],e) @@ -1231,7 +1231,7 @@ compHasFormat (pred is ["has",olda,b]) == --% IF compIf: (%Form,%Mode,%Env) -> %Maybe %Triple -compPredicate: (%Form,%Env) -> %List +compPredicate: (%Form,%Env) -> %Code compFromIf: (%Form,%Mode,%Env) -> %Maybe %Triple compIf(["IF",a,b,c],m,E) == @@ -1935,7 +1935,7 @@ compMapCond'(cexpr,dc) == stackMessage('"not known that %1pb has %2pb",[dc,cexpr]) false -compMapCond: (%Mode,%List) -> %Code +compMapCond: (%Mode,%List %Code) -> %Code compMapCond(dc,[cexpr,fnexpr]) == compMapCond'(cexpr,dc) => fnexpr stackMessage('"not known that %1pb has %2pb",[dc,cexpr]) diff --git a/src/interp/database.boot b/src/interp/database.boot index 487f85e7..05a3e845 100644 --- a/src/interp/database.boot +++ b/src/interp/database.boot @@ -57,109 +57,109 @@ pathToDatabase name == --% -getConstructorAbbreviationFromDB: %Symbol -> %Symbol +getConstructorAbbreviationFromDB: %Constructor -> %Symbol getConstructorAbbreviationFromDB ctor == GETDATABASE(ctor,"ABBREVIATION") -getConstructorCategoryFromDB: %Symbol -> %Form +getConstructorCategoryFromDB: %Constructor -> %Form getConstructorCategoryFromDB ctor == GETDATABASE(ctor,"CONSTRUCTORCATEGORY") -getConstructorKindFromDB: %Symbol -> %Maybe %ConstructorKind +getConstructorKindFromDB: %Constructor -> %Maybe %ConstructorKind getConstructorKindFromDB ctor == GETDATABASE(ctor,"CONSTRUCTORKIND") -getConstructorAncestorsFromDB: %Symbol -> %List +getConstructorAncestorsFromDB: %Constructor -> %List %Constructor getConstructorAncestorsFromDB ctor == GETDATABASE(ctor,"ANCESTORS") ++ return the modemap of the constructor or the instantiation ++ of the constructor `form'. -getConstructorModemapFromDB: %Symbol -> %Mode +getConstructorModemapFromDB: %Constructor -> %Mode getConstructorModemapFromDB form == GETDATABASE(opOf form, 'CONSTRUCTORMODEMAP) -getConstructorFormFromDB: %Symbol -> %Form +getConstructorFormFromDB: %Constructor -> %Form getConstructorFormFromDB ctor == GETDATABASE(ctor,"CONSTRUCTORFORM") -getConstructorSourceFileFromDB: %Symbol -> %Maybe %String +getConstructorSourceFileFromDB: %Constructor -> %Maybe %String getConstructorSourceFileFromDB ctor == GETDATABASE(ctor,"SOURCEFILE") -getConstructorModuleFromDB: %Symbol -> %Maybe %String +getConstructorModuleFromDB: %Constructor -> %Maybe %String getConstructorModuleFromDB ctor == GETDATABASE(ctor,"OBJECT") -getConstructorDocumentationFromDB: %Symbol -> %List +getConstructorDocumentationFromDB: %Constructor -> %List %Form getConstructorDocumentationFromDB ctor == GETDATABASE(ctor,"DOCUMENTATION") -getConstructorOperationsFromDB: %Symbol -> %List +getConstructorOperationsFromDB: %Constructor -> %List %List %Form getConstructorOperationsFromDB ctor == GETDATABASE(ctor,"OPERATIONALIST") -getConstructorFullNameFromDB: %Symbol -> %Symbol +getConstructorFullNameFromDB: %Symbol -> %Constructor getConstructorFullNameFromDB ctor == GETDATABASE(ctor,"CONSTRUCTOR") -getConstructorArgsFromDB: %Symbol -> %List +getConstructorArgsFromDB: %Constructor -> %List %Symbol getConstructorArgsFromDB ctor == GETDATABASE(ctor,"CONSTRUCTORARGS") ++ returns a list of Boolean values indicating whether the ++ parameter type at the corresponding position is a category. -getDualSignatureFromDB: %Symbol -> %Form +getDualSignatureFromDB: %Constructor -> %Form getDualSignatureFromDB ctor == GETDATABASE(ctor,"COSIG") -getConstructorPredicatesFromDB: %Symbol -> %Thing +getConstructorPredicatesFromDB: %Constructor -> %Thing getConstructorPredicatesFromDB ctor == GETDATABASE(ctor,"PREDICATES") -getConstructorParentsFromDB: %Symbol -> %List +getConstructorParentsFromDB: %Constructor -> %List %Constructor getConstructorParentsFromDB ctor == GETDATABASE(ctor,"PARENTS") -getSuperDomainFromDB: %Symbol -> %Form +getSuperDomainFromDB: %Constructor -> %Form getSuperDomainFromDB ctor == GETDATABASE(ctor,"SUPERDOMAIN") -getConstructorAttributesFromDB: %Symbol -> %Form +getConstructorAttributesFromDB: %Constructor -> %Form getConstructorAttributesFromDB ctor == GETDATABASE(ctor,"ATTRIBUTES") -niladicConstructorFromDB: %Symbol -> %Boolean +niladicConstructorFromDB: %Constructor -> %Boolean niladicConstructorFromDB ctor == GETDATABASE(ctor,"NILADIC") -asharpConstructorFromDB: %Symbol -> %Maybe %Symbol +asharpConstructorFromDB: %Constructor -> %Maybe %Symbol asharpConstructorFromDB ctor == GETDATABASE(ctor,"ASHARP?") -constructorHasCategoryFromDB: %Pair -> %Thing +constructorHasCategoryFromDB: %Pair(%Thing,%Thing) -> %List %Code constructorHasCategoryFromDB p == GETDATABASE(p,"HASCATEGORY") -getConstructorDefaultFromDB: %Symbol -> %Maybe %Symbol +getConstructorDefaultFromDB: %Constructor -> %Maybe %Symbol getConstructorDefaultFromDB ctor == GETDATABASE(ctor,"DEFAULTDOMAIN") -getOperationFromDB: %Symbol -> %List +getOperationFromDB: %Symbol -> %List %Sig getOperationFromDB op == GETDATABASE(op,"OPERATION") -getOperationModemapsFromDB: %Symbol -> %List +getOperationModemapsFromDB: %Symbol -> %List %Modemap getOperationModemapsFromDB op == GETDATABASE(op,"MODEMAPS") -getConstructorArity: %Symbol -> %Short +getConstructorArity: %Constructor -> %Short getConstructorArity ctor == sig := getConstructorSignature ctor => #rest sig -1 -getConstructorKind: %Symbol -> %Maybe %ConstructorKind +getConstructorKind: %Constructor -> %Maybe %ConstructorKind getConstructorKind ctor == kind := getConstructorKindFromDB ctor => kind = "domain" and isDefaultPackageName ctor => "package" @@ -785,12 +785,12 @@ displayHiddenConstructors() == ++ Return the list of modemaps exported by the category object `c'. ++ The format of modemap is as found in category objects. -getCategoryExports: %Shell -> %List +getCategoryExports: %Shell -> %List %Modemap getCategoryExports c == c.1 ++ Return the list of category attribute info for the category object `c'. ++ A category attribute info is pair of attribute-predicate. -getCategoryAttributes: %Shell -> %List +getCategoryAttributes: %Shell -> %List %Form getCategoryAttributes c == c.2 @@ -800,7 +800,7 @@ getCategoryParents c == c.4.1 --% -squeezeAll: %List -> %List +squeezeAll: %List %Code -> %List %Code squeezeAll x == [SQUEEZE t for t in x] diff --git a/src/interp/define.boot b/src/interp/define.boot index acca5b76..9b1cb4ed 100644 --- a/src/interp/define.boot +++ b/src/interp/define.boot @@ -109,8 +109,8 @@ $subdomain := false --% -compDefineAddSignature: (%Form,%Signature,%Env) -> %Env -DomainSubstitutionFunction: (%List,%Form) -> %Form +compDefineAddSignature: (%Form,%Sig,%Env) -> %Env +DomainSubstitutionFunction: (%List %Symbol,%Form) -> %Form --% @@ -473,7 +473,7 @@ compDefine(form,m,e) == ++ per: Rep -> % ++ rep: % -> Rep ++ as local inline functions. -checkRepresentation: (%Form,%List,%Env) -> %Env +checkRepresentation: (%Form,%List %Form,%Env) -> %Env checkRepresentation(addForm,body,env) == domainRep := nil hasAssignRep := false -- assume code does not assign to Rep. @@ -853,7 +853,7 @@ compMakeCategoryObject(c,$e) == u:= mkEvalableCategoryForm c => [eval u,$Category,$e] nil -predicatesFromAttributes: %List -> %List +predicatesFromAttributes: %List %Form -> %List %Form predicatesFromAttributes attrList == removeDuplicates [second x for x in attrList] @@ -1155,7 +1155,7 @@ genDomainView(viewName,originalName,c,viewSelector) == $getDomainCode:= [cd,:$getDomainCode] viewName -genDomainViewList: (%Symbol,%List) -> %List +genDomainViewList: (%Symbol,%List %Form) -> %List %Code genDomainViewList(id,catlist) == [genDomainView(id,id,cat,"getDomainView") for cat in catlist | isCategoryForm(cat,$EmptyEnvironment)] @@ -1928,7 +1928,7 @@ mustInstantiate D == D is [fn,:.] and not (symbolMember?(fn,$DummyFunctorNames) or GET(fn,"makeFunctionList")) -wrapDomainSub: (%List, %Form) -> %Form +wrapDomainSub: (%List %Form, %Form) -> %Form wrapDomainSub(parameters,x) == ["DomainSubstitutionMacro",parameters,x] diff --git a/src/interp/g-util.boot b/src/interp/g-util.boot index 1880e41e..6f04fea8 100644 --- a/src/interp/g-util.boot +++ b/src/interp/g-util.boot @@ -40,8 +40,8 @@ namespace BOOT module g_-util where atomic?: %Thing -> %Boolean getTypeOfSyntax: %Form -> %Mode - pairList: (%List,%List) -> %List - mkList: %List -> %List + pairList: (%List %Form,%List %Form) -> %List %Pair(%Form.%Form) + mkList: %List %Form -> %Form isSubDomain: (%Mode,%Mode) -> %Form usedSymbol?: (%Symbol,%Code) -> %Boolean isDefaultPackageName: %Symbol -> %Boolean @@ -212,9 +212,9 @@ ScanOrPairVec(f, ob) == ++ Query properties for an entity in a given environment. -get: (%Thing,%Symbol,%List) -> %Thing -get0: (%Thing,%Symbol,%List) -> %Thing -get1: (%Thing,%Symbol,%List) -> %Thing +get: (%Thing,%Symbol,%Env) -> %Thing +get0: (%Thing,%Symbol,%Env) -> %Thing +get1: (%Thing,%Symbol,%Env) -> %Thing get2: (%Thing,%Symbol) -> %Thing get(x,prop,e) == @@ -244,13 +244,13 @@ get2(x,prop) == ++ Update properties of an entity in an environment. put: (%Thing,%Symbol,%Thing,%Env) -> %Env -addBinding: (%Thing,%List,%Env) -> %Env -addBindingInteractive: (%Thing, %List, %Env) -> %Env -augProplistOf: (%Thing,%Symbol,%Thing,%Env) -> %List -augProplist: (%List,%Symbol,%Thing) -> %List -augProplistInteractive: (%List,%Symbol,%Thing) -> %List +addBinding: (%Thing,%List %Thing,%Env) -> %Env +addBindingInteractive: (%Thing, %List %Thing, %Env) -> %Env +augProplistOf: (%Thing,%Symbol,%Thing,%Env) -> %List %Thing +augProplist: (%List %Thing,%Symbol,%Thing) -> %List %Thing +augProplistInteractive: (%List %Thing,%Symbol,%Thing) -> %List %Thing putIntSymTab: (%Thing,%Symbol,%Form,%Env) -> %Env -addIntSymTabBinding: (%Thing,%List,%Env) -> %Env +addIntSymTabBinding: (%Thing,%List %Thing,%Env) -> %Env put(x,prop,val,e) == $InteractiveMode and not sameObject?(e,$CategoryFrame) => @@ -672,10 +672,10 @@ opOf x == cons? x => x.op x -getProplist: (%Thing,%Env) -> %List -search: (%Thing,%Env) -> %List -searchCurrentEnv: (%Thing,%List) -> %List -searchTailEnv: (%Thing,%Env) -> %List +getProplist: (%Thing,%Env) -> %List %Thing +search: (%Thing,%Env) -> %List %Thing +searchCurrentEnv: (%Thing,%List %Thing) -> %List %Thing +searchTailEnv: (%Thing,%Env) -> %List %Thing getProplist(x,E) == cons? x => getProplist(first x,E) diff --git a/src/interp/i-analy.boot b/src/interp/i-analy.boot index 718897ec..7a404c41 100644 --- a/src/interp/i-analy.boot +++ b/src/interp/i-analy.boot @@ -705,7 +705,7 @@ sayIntelligentMessageAboutOpAvailability(opName, nArgs) == ++ Returns the `conceptual' type of `type', e.g., the type of type in ++ the abstract semantics, not necessarily the one from implementation ++ point of view. -conceptualType: %Thing -> %List +conceptualType: %Thing -> %Mode conceptualType type == isPartialMode type => $Mode member(type,[$Mode,$Domain,$Category]) => $Type diff --git a/src/interp/lisplib.boot b/src/interp/lisplib.boot index 3fc01131..2f34523b 100644 --- a/src/interp/lisplib.boot +++ b/src/interp/lisplib.boot @@ -809,7 +809,7 @@ getIndexPathname: %String -> %String getIndexPathname dir == strconc(ensureTrailingSlash dir, $IndexFilename) -getAllIndexPathnames: %String -> %List +getAllIndexPathnames: %String -> %List %Form getAllIndexPathnames dir == -- GCL's semantics of Common Lisp's `DIRECTORY *' differs from the -- rest of everybody else' semantics. Namely, GCL would return a @@ -822,7 +822,7 @@ getAllIndexPathnames dir == )endif -getAllAldorObjectFiles: %String -> %List +getAllAldorObjectFiles: %String -> %List %Form getAllAldorObjectFiles dir == asys := DIRECTORY strconc(dir,'"*.asy") asos := DIRECTORY strconc(dir,'"*.ao") diff --git a/src/interp/modemap.boot b/src/interp/modemap.boot index 75662d27..5197dfae 100644 --- a/src/interp/modemap.boot +++ b/src/interp/modemap.boot @@ -505,9 +505,9 @@ knownInfo pred == pred is ["or",:l] => or/[knownInfo u for u in l] pred is ["and",:l] => and/[knownInfo u for u in l] pred is ["ATTRIBUTE",name,attr] => - v:= compForMode(name,$EmptyMode,$e) or return + v := compForMode(name,$EmptyMode,$e) or return stackAndThrow('"can't find category of %1pb",[name]) - [vv,.,.]:= compMakeCategoryObject(second v,$e) or return + [vv,.,.] := compMakeCategoryObject(v.mode,$e) or return stackAndThrow('"can't make category of %1pb",[name]) listMember?(attr,vv.2) => true x := assoc(attr,vv.2) => knownInfo second x @@ -517,7 +517,7 @@ knownInfo pred == cat is ["ATTRIBUTE",:a] => knownInfo ["ATTRIBUTE",name,:a] cat is ["SIGNATURE",:a] => knownInfo ["SIGNATURE",name,:a] -- unnamed category expressions imply structural checks. - cat is ["Join",:.] => and/[knownInfo ["has",name,c] for c in rest cat] + cat is ["Join",:.] => and/[knownInfo ["has",name,c] for c in cat.args] cat is ["CATEGORY",.,:atts] => and/[knownInfo hasToInfo ["has",name,att] for att in atts] name is ['Union,:.] => false @@ -563,8 +563,12 @@ actOnInfo(u,$e) == u is ["ATTRIBUTE",name,att] => [vval,vmode,.]:= GetValue name compilerMessage('"augmenting %1: %2p", [name,["ATTRIBUTE",att]]) - key:= if CONTAINED("$",vmode) then "domain" else name - cat:= ["CATEGORY",key,["ATTRIBUTE",att]] + key := + -- FIXME: there should be a better to tell whether name + -- designates a domain, as opposed to a package + CONTAINED("$",vmode) => 'domain + 'package + cat := ["CATEGORY",key,["ATTRIBUTE",att]] $e:= put(name,"value",[vval,mkJoin(cat,vmode),nil],$e) --there is nowhere %else that this sort of thing exists u is ["SIGNATURE",name,operator,modemap,:q] => @@ -580,7 +584,11 @@ actOnInfo(u,$e) == [vval,vmode,.]:= GetValue name compilerMessage('"augmenting %1: %2p", [name,["SIGNATURE",operator,modemap,:q]]) - key:= if CONTAINED("$",vmode) then "domain" else name + key := + -- FIXME: there should be a better to tell whether name + -- designates a domain, as opposed to a package + CONTAINED("$",vmode) => 'domain + 'package cat:= ["CATEGORY",key,["SIGNATURE",operator,modemap,:q]] $e:= put(name,"value",[vval,mkJoin(cat,vmode),nil],$e) u is ["has",name,cat] => diff --git a/src/interp/parse.boot b/src/interp/parse.boot index 607a646a..4cdbeb82 100644 --- a/src/interp/parse.boot +++ b/src/interp/parse.boot @@ -87,7 +87,7 @@ parseTypeList l == l = nil => nil [parseType first l, :parseTypeList rest l] -parseTranList: %List -> %List +parseTranList: %List %Form -> %List %Form parseTranList l == atom l => parseTran l [parseTran first l,:parseTranList rest l] @@ -358,13 +358,13 @@ makeSimplePredicateOrNil p == wrapSEQExit [["%LET",g:= gensym(),p],g] -parseWhere: %List -> %Form +parseWhere: %List %Form -> %Form parseWhere t == t isnt ["where",:l] => systemErrorHere ["parseWhere",t] ["where",:parseTranList l] -parseSeq: %List -> %Form +parseSeq: %List %Form -> %Form parseSeq t == t isnt ["SEQ",:l] => systemErrorHere ["parseSeq",t] l isnt [:.,["exit",:.]] => @@ -372,7 +372,7 @@ parseSeq t == transSeq parseTranList l -transSeq: %List -> %Form +transSeq: %List %Form -> %Form transSeq l == l = nil => nil l is [x] => decExitLevel x @@ -412,7 +412,7 @@ transCategoryItem x == [x] -superSub: (%Symbol, %List) -> %Form +superSub: (%Symbol, %List %Form ) -> %Form superSub(name,x) == for u in x repeat y:= [:y,:u] code:= @@ -420,22 +420,22 @@ superSub(name,x) == strconc('"_(",scriptTranRow first x,scriptTran rest x,'"_)") [INTERNL(symbolName name,"$",code),:y] -scriptTran: %List -> %String +scriptTran: %List %Form -> %String scriptTran x == x = nil => '"" strconc('";",scriptTranRow first x,scriptTran rest x) -scriptTranRow: %List -> %String +scriptTranRow: %List %Form -> %String scriptTranRow x == x = nil => '"" strconc($quadSymbol,scriptTranRow1 rest x) -scriptTranRow1: %List -> %String +scriptTranRow1: %List %Form -> %String scriptTranRow1 x == x = nil => '"" strconc('",",$quadSymbol,scriptTranRow1 rest x) -parseVCONS: %List -> %Form +parseVCONS: %List %Form -> %Form parseVCONS l == ["VECTOR",:parseTranList rest l] diff --git a/src/interp/posit.boot b/src/interp/posit.boot index 114916ee..82d1f09d 100644 --- a/src/interp/posit.boot +++ b/src/interp/posit.boot @@ -35,10 +35,10 @@ import sys_-macros import astr namespace BOOT module posit where - %Position <=> %List - tokType: %List -> %Symbol - tokPart: %List -> %Thing - tokPosn: %List -> %Position + %Position <=> %List %Form + tokType: %List %Form -> %Symbol + tokPart: %List %Form -> %Thing + tokPosn: %List %Form -> %Position $nopos == ['noposition] diff --git a/src/interp/postpar.boot b/src/interp/postpar.boot index 602732d9..ba65872b 100644 --- a/src/interp/postpar.boot +++ b/src/interp/postpar.boot @@ -39,11 +39,11 @@ module postpar ++ The type of parse trees. %ParseTree <=> - %Number or %Symbol or %String or %Pair + %Number or %Symbol or %String or %Pair(%Thing,%Thing) ++ The result of processing a parse tree. %ParseForm <=> - %Number or %Symbol or %String or %Pair + %Number or %Symbol or %String or %Pair(%Thing,%Thing) $postStack := [] @@ -92,7 +92,7 @@ postTran x == op ~= (y:= postOp op) => [y,:postTranList rest x] postForm x -postTranList: %List -> %List +postTranList: %List %ParseTree -> %List %ParseForm postTranList x == [postTran y for y in x] @@ -187,7 +187,7 @@ postBlock t == t isnt ["%Block",:l,x] => systemErrorHere ["postBlock",t] ["SEQ",:postBlockItemList l,["exit",postTran x]] -postBlockItemList: %List -> %List +postBlockItemList: %List %ParseTree -> %List %ParseTree postBlockItemList l == [postBlockItem x for x in l] @@ -241,7 +241,7 @@ postDef t == specialCaseForm := [nil for x in form] ["DEF",newLhs,typeList,specialCaseForm,postTran rhs] -postDefArgs: %List -> %List +postDefArgs: %List %ParseTree -> %List %ParseForm postDefArgs argl == null argl => argl argl is [[":",a],:b] => @@ -316,7 +316,7 @@ postQuote [.,a] == ["QUOTE",a] -postScriptsForm: (%ParseTree,%List) -> %ParseForm +postScriptsForm: (%ParseTree,%List %ParseTree) -> %ParseForm postScriptsForm(t,argl) == t isnt ["Scripts",op,a] => systemErrorHere ["postScriptsForm",t] [getScriptName(op,a,#argl),:postTranScripts a,:argl] @@ -416,7 +416,7 @@ postTupleCollect t == t isnt [constructOp,:m,x] => systemErrorHere ["postTupleCollect",t] postCollect [constructOp,:m,["construct",x]] -postIteratorList: %List -> %List +postIteratorList: %List %ParseTree -> %List %ParseForm postIteratorList x == x is [p,:l] => (p:= postTran p) is ["IN",y,u] => diff --git a/src/interp/serror.boot b/src/interp/serror.boot index 59318cbd..9dcf1c3a 100644 --- a/src/interp/serror.boot +++ b/src/interp/serror.boot @@ -37,20 +37,20 @@ namespace BOOT --% Functions to handle specific errors (mostly syntax) -syGeneralErrorHere: () -> %Thing +syGeneralErrorHere: () -> %Void syGeneralErrorHere() == sySpecificErrorHere('S2CY0002, []) -sySpecificErrorHere: (%Symbol,%List) -> %Thing +sySpecificErrorHere: (%Symbol,%List %Form) -> %Void sySpecificErrorHere(key,args) == sySpecificErrorAtToken($stok, key, args) -sySpecificErrorAtToken: (%Thing,%Symbol,%List) -> %Thing +sySpecificErrorAtToken: (%Thing,%Symbol,%List %Form) -> %Void sySpecificErrorAtToken(tok,key,args) == pos := tokPosn tok ncSoftError(pos, key, args) -syIgnoredFromTo: (%List,%List) -> %Thing +syIgnoredFromTo: (%List %Form,%List %Form) -> %Void syIgnoredFromTo(pos1, pos2) == if pfGlobalLinePosn pos1 = pfGlobalLinePosn pos2 then ncSoftError(FromTo(pos1,pos2), 'S2CY0005, []) @@ -58,7 +58,7 @@ syIgnoredFromTo(pos1, pos2) == ncSoftError(From pos1, 'S2CY0003, []) ncSoftError(To pos2, 'S2CY0004, []) -npTrapForm: %Thing -> %Thing +npTrapForm: %Thing -> %Void npTrapForm(x)== a:=pfSourceStok x a='NoToken => diff --git a/src/interp/sys-utility.boot b/src/interp/sys-utility.boot index 6d9bf52c..349304f8 100644 --- a/src/interp/sys-utility.boot +++ b/src/interp/sys-utility.boot @@ -82,15 +82,15 @@ getVMType d == IntegerMod => "%Integer" DoubleFloat => "%DoubleFloat" String => "%String" - List => "%List" + List => ["%List",getVMType second d'] Vector => ["%Vector",getVMType second d'] PrimitiveArray => ["%SimpleArray", getVMType second d'] - Pair => "%Pair" - Union => "%Pair" + Pair => ["%Pair",getVMType second d',getVMType third d'] + Union => ["%Pair",'%Thing,'%Thing] Record => #rest d' > 2 => "%Shell" - "%Pair" - IndexedList => "%List" + ["%Pair",'%Thing,'%Thing] + IndexedList => ["%List", getVMType second d'] Int8 => ["SIGNED-BYTE", 8] Int16 => ["SIGNED-BYTE", 16] Int32 => ["SIGNED-BYTE", 32] @@ -117,7 +117,6 @@ functionp f == function? f ++ remove `item' from `sequence'. -delete: (%Thing,%Sequence) -> %Sequence delete(item,sequence) == symbol? item => REMOVE(item,sequence,KEYWORD::TEST,function sameObject?) @@ -154,7 +153,7 @@ ASSOCRIGHT x == ++ Put the association list pair `(x . y)' into `l', erasing any ++ previous association for `x'. -ADDASSOC: (%Thing,%Thing,%List) -> %List +ADDASSOC: (%Thing,%Thing,%Alist(%Thing,%Thing)) -> %Alist(%Thing,%Thing) ADDASSOC(x,y,l) == atom l => [[x,:y],:l] x = first first l => [[x,:y],:rest l] @@ -162,7 +161,7 @@ ADDASSOC(x,y,l) == ++ Remove any assocation pair `(u . x)' from list `v'. -DELLASOS: (%Thing,%List) -> %List +DELLASOS: (%Thing,%Alist(%Thing,%Thing)) -> %Alist(%Thing,%Thing) DELLASOS(u,v) == atom v => nil u = first first v => rest v @@ -171,14 +170,14 @@ DELLASOS(u,v) == ++ Return the datum associated with key `x' in association list `y'. -- ??? Should not this be named `alistValue'? -LASSOC: (%Thing,%List) -> %Thing +LASSOC: (%Thing,%Alist(%Thing,%Thing)) -> %Thing LASSOC(x,y) == atom y => nil x = first first y => rest first y LASSOC(x,rest y) ++ Return the key associated with datum `x' in association list `y'. -rassoc: (%Thing,%List) -> %Thing +rassoc: (%Thing,%Alist(%Thing,%Thing)) -> %Thing rassoc(x,y) == atom y => nil x = rest first y => first first y diff --git a/src/interp/types.boot b/src/interp/types.boot index 6022a5cb..915279ee 100644 --- a/src/interp/types.boot +++ b/src/interp/types.boot @@ -34,117 +34,14 @@ import boot_-pkg namespace BOOT ---% Basic types used throughout Boot codes. - -++ Type of nothing. Bottom of the abstract machine type lattice. -++ Since Lisp functions always returns something, we cannot -++ use the `nil' type specifier (the ideal answer). Second -++ best possibility is to have Void-returning functions -++ systematically return `nil'. However, until the Lisp -++ backend is fixed, we will use the interpretation that a -++ Void-returning function may return anything, but nobody cares. -++ Hence, the choice below which contradicts the very first line -++ of this description. -%Void <=> - true - -++ Type of truth values. -%Boolean <=> - BOOLEAN - -++ Type of a bit value. -%Bit <=> - BIT - -++ Type of 8-bit sized unsigned integer values. -%Byte <=> - UNSIGNED_-BYTE 8 - -++ Type of characters -- no distinction yet. -%Char <=> - CHARACTER - -++ Type of fixnums. -%Short <=> - FIXNUM - -++ Type of unlimited precision integers. -%Bignum <=> - BIGNUM - -%Integer <=> - INTEGER - -%IntegerSection n <=> - INTEGER n - -++ Type of single precision floating point numbers. Most of the -++ time, this is a 32-bit datatype on IEEE-754 host. -%SingleFloat <=> -)if %hasFeature KEYWORD::GCL - SHORT_-FLOAT -)else - SINGLE_-FLOAT -)endif - -++ Type of double precision floating point numbers. Most of the time, -++ this is a 64-bit sized datatype on IEEE-756 host. -%DoubleFloat <=> - DOUBLE_-FLOAT - -++ General type for numbers. -%Number <=> - NUMBER - -++ Type of identifiers. Ideally, we want actually want to exclude -++ Lisp oddities such as NIL and T. -%Symbol <=> - SYMBOL - -++ The type of literal strings -%String <=> - STRING - -++ Anything that is not a cons cell. -%Atom <=> atom - -++ nil or a cons cell. Ideally, this should be parameterized, but -++ we cannot afford that luxury with Lisp. -%List <=> - LIST - -++ The type of a linear homogeneous non-extensible array. -%SimpleArray a <=> - SIMPLE_-ARRAY a - -%Vector a <=> VECTOR a - -%BitVector <=> %Vector %Bit - -%Thing <=> true - -%Sequence <=> SEQUENCE - -%Pair <=> CONS +--% Data structures for the compiler -%Maybe a <=> null or a +%Alist(s,t) <=> %List %Pair(s,t) -- association list ---% Data structures for the compiler %Constructor <=> %Symbol -- constructor -%Form <=> %Number or %Symbol or %String or %Pair -- input syntax form %Instantiation <=> [%Constructor,:%Form] -- constructor instance -%Env <=> %List -- compiling env -%Mode <=> %Symbol or %String or %List -- type of forms -%Code <=> %Form or %Char -- generated code -%Triple <=> -- form + type + env - [%Code,:[%Mode,:[%Env,:null]]] - -%Signature -- signature - <=> %Symbol or %Pair -%Modemap <=> %List -- modemap +%Modemap <=> %List(%Form) -- modemap %ConstructorKind <=> -- kind of ctor instances MEMBER(category,domain,package) - -%Shell <=> SIMPLE_-VECTOR -- constructor instantiation diff --git a/src/lisp/core.lisp.in b/src/lisp/core.lisp.in index 0493d884..4c06f25c 100644 --- a/src/lisp/core.lisp.in +++ b/src/lisp/core.lisp.in @@ -3,7 +3,7 @@ ;; Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd. ;; All rights reserved. ;; -;; Copyright (C) 2007-2010, Gabriel Dos Reis. +;; Copyright (C) 2007-2011, Gabriel Dos Reis. ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without @@ -58,7 +58,39 @@ ;; Clozure CL sequesters most of its useful extensions, in particular ;; threads, in the CCL package. #+:clozure (:use "CCL") - (:export "coreQuit" + (:export "%Thing" + "%Void" + "%Boolean" + "%String" + "%Symbol" + "%Short" + "%Bit" + "%Byte" + "%Char" + "%Bignum" + "%Integer" + "%Number" + "%IntegerSection" + "%SingleFloat" + "%DoubleFloat" + "%Atom" + "%Maybe" + "%Pair" + "%List" + "%Vector" + "%BitVector" + "%SimpleArray" + + ;; compiler data structures + "%Mode" + "%Sig" + "%Code" + "%Env" + "%Form" + "%Triple" + "%Shell" + + "coreQuit" "fatalError" "internalError" "coreError" @@ -119,6 +151,84 @@ (in-package "AxiomCore") ;; +;; -*- Basic data types -*- +;; + +;; Type of nothing. Bottom of the abstract machine type lattice. +;; Since Lisp functions always returns something, we cannot +;; use the `nil' type specifier (the ideal answer). Second +;; best possibility is to have Void-returning functions +;; systematically return `nil'. However, until the Lisp +;; backend is fixed, we will use the interpretation that a +;; Void-returning function may return anything, but nobody cares. +;; Hence, the choice below which contradicts the very first line +;; of this description. +(deftype |%Void| () 't) + +(deftype |%Thing| () 't) + +(deftype |%Boolean| () 'boolean) + +(deftype |%String| () 'string) + +(deftype |%Symbol| () 'symbol) + +(deftype |%Short| () 'fixnum) + +(deftype |%Bit| () 'bit) + +(deftype |%Byte| () '(unsigned-byte 8)) + +(deftype |%Char| () 'character) + +(deftype |%Bignum| () 'bignum) + +(deftype |%Integer| () 'integer) + +(deftype |%IntegerSection| (n) `(integer ,n)) + +(deftype |%SingleFloat| () + #+ :gcl 'short-float + #- :gcl 'single-float) + +(deftype |%DoubleFloat| () 'double-float) + +(deftype |%Number| () 'number) + +(deftype |%Atom| () 'atom) + +(deftype |%Maybe| (s) `(or null ,s)) + +(deftype |%Pair| (u v) + (declare (ignore u v)) + 'cons) + +(deftype |%List| (s) + (declare (ignore s)) + 'list) + +(deftype |%SimpleArray| (s) `(simple-array ,s)) + +(deftype |%Vector| (s) `(vector ,s)) + +(deftype |%BitVector| () '(simple-array bit)) + +(deftype |%Shell| () 'simple-vector) + +(deftype |%Mode| () '(or symbol string cons)) + +(deftype |%Sig| () '(or symbol cons)) + +(deftype |%Code| () '(or |%Form| |%Char|)) + +(deftype |%Env| () '(or null cons)) + +(deftype |%Form| () '(or number symbol string cons)) + +(deftype |%Triple| () + '(cons |%Code| (cons |%Mode| (cons |%Env| null)))) + +;; ;; -*- Configuration Constants -*- ;; @@ -149,7 +259,8 @@ (proclaim '(optimize @oa_optimize_options@)) ;; Enablig profiling of generated Lisp codes. -(defconstant |$EnableLispProfiling| @oa_enable_profiling@) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant |$EnableLispProfiling| @oa_enable_profiling@)) (eval-when (:compile-toplevel :load-toplevel :execute) (when |$EnableLispProfiling| |