diff options
| -rw-r--r-- | src/ChangeLog | 4 | ||||
| -rw-r--r-- | src/boot/ast.boot | 25 | ||||
| -rw-r--r-- | src/boot/translator.boot | 760 |
3 files changed, 357 insertions, 432 deletions
diff --git a/src/ChangeLog b/src/ChangeLog index 70baa3c2..7b37fdad 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,7 @@ +2008-04-19 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * boot/translator.boot: Cleanup. + 2008-04-18 Gabriel Dos Reis <gdr@cs.tamu.edu> * boot/ast.boot (%DefaultValue): New %Ast node. diff --git a/src/boot/ast.boot b/src/boot/ast.boot index ab37de68..cf186896 100644 --- a/src/boot/ast.boot +++ b/src/boot/ast.boot @@ -48,28 +48,34 @@ import '"includer" ++ translated with the obvious semantics, e.g. no caching. $bfClamming := false -++ Basic types used in Boot codes. +--% Basic types used in Boot codes. + %Thing <=> true + %Boolean <=> BOOLEAN + %String <=> STRING + %Symbol <=> SYMBOL + %Short <=> FIXNUM -%List <=> LIST -%Vector <=> VECTOR -%Sequence <=> SEQUENCE ++ Ideally, we would like to say that a List T if either nil or a -++ cons of a T and List of T. However, we don't support parameterized -++ alias definitions yet. +++ 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 want to intern `on demand'. How that +++ 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 %Name == + %Name(%Symbol) -structure Ast == +structure %Ast == Command(%String) -- includer command Module(%String) -- module declaration Import(%String) -- import module @@ -121,6 +127,7 @@ structure Ast == $inDefIS := false +++ returns a `quote' ast for x. quote x == ["QUOTE",x] diff --git a/src/boot/translator.boot b/src/boot/translator.boot index 8222cab4..bfaab592 100644 --- a/src/boot/translator.boot +++ b/src/boot/translator.boot @@ -46,28 +46,27 @@ import '"ast" $translatingOldBoot := false AxiomCore::%sysInit() == - if cdr ASSOC(Option '"boot", %systemOptions()) = '"old" + if rest ASSOC(Option '"boot", %systemOptions()) = '"old" then $translatingOldBoot := true --- Make x, the current package +++ Make x, the current package +setCurrentPackage: %Thing -> %Thing setCurrentPackage x == SETQ(_*PACKAGE_*,x) --- Compiles the input Lisp file designated by lspFileName. +++ Compiles the input Lisp file designated by lspFileName. +shoeCOMPILE_-FILE: %String -> %Thing shoeCOMPILE_-FILE lspFileName == COMPILE_-FILE lspFileName --- (boottocl "filename") translates the file "filename.boot" to --- the common lisp file "filename.clisp" BOOTTOCL(fn, out) == BOOTTOCLLINES(nil,fn, out) --- (bootclam "filename") translates the file "filename.boot" to --- the common lisp file "filename.clisp" , producing, for each function --- a hash table to store previously computed values indexed by argument --- list. - +++ (bootclam "filename") translates the file "filename.boot" to +++ the common lisp file "filename.clisp" , producing, for each function +++ a hash table to store previously computed values indexed by argument +++ list. BOOTCLAM(fn, out) == $bfClamming := true BOOTCLAMLINES(nil,fn, out) @@ -87,20 +86,18 @@ BOOTTOCLLINES(lines, fn, outfn)== result shoeClLines(a,fn,lines,outfn)== - if null a - then shoeNotFound fn - else - $GenVarCounter:local := 0 - shoeOpenOutputFile(stream,outfn, - (for line in lines repeat shoeFileLine (line,stream); - shoeFileTrees(shoeTransformStream a,stream))) - outfn - --- (boottoclc "filename") translates the file "filename.boot" to --- the common lisp file "filename.clisp" with the original boot --- code as comments - -BOOTTOCLC(fn, out)==BOOTTOCLCLINES(nil, fn, out) + a=nil => shoeNotFound fn + $GenVarCounter := 0 + shoeOpenOutputFile(stream,outfn, + (for line in lines repeat shoeFileLine (line,stream); + shoeFileTrees(shoeTransformStream a,stream))) + outfn + +++ (boottoclc "filename") translates the file "filename.boot" to +++ the common lisp file "filename.clisp" with the original boot +++ code as comments +BOOTTOCLC(fn, out)== + BOOTTOCLCLINES(nil, fn, out) BOOTTOCLCLINES(lines, fn, outfn)== callingPackage := _*PACKAGE_* @@ -113,34 +110,30 @@ BOOTTOCLCLINES(lines, fn, outfn)== shoeClCLines(a,fn,lines,outfn)== - if null a - then shoeNotFound fn - else - $GenVarCounter:local := 0 - shoeOpenOutputFile(stream,outfn, - (for line in lines repeat shoeFileLine (line,stream); - shoeFileTrees(shoeTransformToFile(stream, - shoeInclude bAddLineNumber(bRgen a,bIgen 0)),stream))) - outfn - --- (boottomc "filename") translates the file "filename.boot" --- to machine code and loads it one item at a time - + a=nil => shoeNotFound fn + $GenVarCounter := 0 + shoeOpenOutputFile(stream,outfn, + (for line in lines repeat shoeFileLine (line,stream); + shoeFileTrees(shoeTransformToFile(stream, + shoeInclude bAddLineNumber(bRgen a,bIgen 0)),stream))) + outfn + +++ (boottomc "filename") translates the file "filename.boot" +++ to machine code and loads it one item at a time +BOOTTOMC: %String -> %Thing BOOTTOMC fn== callingPackage := _*PACKAGE_* IN_-PACKAGE '"BOOTTRAN" - $GenVarCounter:local := 0 + $GenVarCounter := 0 infn:=shoeAddbootIfNec fn result := shoeOpenInputFile(a,infn,shoeMc(a,fn)) setCurrentPackage callingPackage result shoeMc(a,fn)== - if null a - then shoeNotFound fn - else - shoePCompileTrees shoeTransformStream a - shoeConsole CONCAT(fn,'" COMPILED AND LOADED") + a=nil => shoeNotFound fn + shoePCompileTrees shoeTransformStream a + shoeConsole strconc(fn,'" COMPILED AND LOADED") EVAL_-BOOT_-FILE fn == b := _*PACKAGE_* @@ -151,50 +144,48 @@ EVAL_-BOOT_-FILE fn == setCurrentPackage b LOAD outfn --- (boot "filename") translates the file "filename.boot" --- and prints the result at the console - +++ (boot "filename") translates the file "filename.boot" +++ and prints the result at the console +BO: %String -> %Thing BO fn== - b := _*PACKAGE_* - IN_-PACKAGE '"BOOTTRAN" - $GenVarCounter:local := 0 - infn:=shoeAddbootIfNec fn - shoeOpenInputFile(a,infn,shoeToConsole(a,fn)) - setCurrentPackage b + b := _*PACKAGE_* + IN_-PACKAGE '"BOOTTRAN" + $GenVarCounter := 0 + infn:=shoeAddbootIfNec fn + shoeOpenInputFile(a,infn,shoeToConsole(a,fn)) + setCurrentPackage b BOCLAM fn== - callingPackage := _*PACKAGE_* - IN_-PACKAGE '"BOOTTRAN" - $GenVarCounter:local := 0 - $bfClamming:local := true - infn:=shoeAddbootIfNec fn - result := shoeOpenInputFile(a,infn,shoeToConsole(a,fn)) - setCurrentPackage callingPackage - result + callingPackage := _*PACKAGE_* + IN_-PACKAGE '"BOOTTRAN" + $GenVarCounter := 0 + $bfClamming := true + infn:=shoeAddbootIfNec fn + result := shoeOpenInputFile(a,infn,shoeToConsole(a,fn)) + setCurrentPackage callingPackage + result shoeToConsole(a,fn)== - if null a - then shoeNotFound fn - else - shoeConsoleTrees shoeTransformToConsole - shoeInclude bAddLineNumber(bRgen a,bIgen 0) + a=nil => shoeNotFound fn + shoeConsoleTrees shoeTransformToConsole + shoeInclude bAddLineNumber(bRgen a,bIgen 0) -- (stout "string") translates the string "string" -- and prints the result at the console STOUT string== PSTOUT [string] --- $GenVarCounter:local := 0 --- $bfClamming:local:=false +-- $GenVarCounter := 0 +-- $bfClamming :=false -- shoeConsoleTrees shoeTransformString [string] STEVAL string== callingPackage := _*PACKAGE_* IN_-PACKAGE '"BOOTTRAN" - $GenVarCounter:local := 0 + $GenVarCounter := 0 a:= shoeTransformString [string] result := bStreamPackageNull a => nil - fn:=stripm(CAR a,_*PACKAGE_*,FIND_-PACKAGE '"BOOTTRAN") + fn:=stripm(first a,_*PACKAGE_*,FIND_-PACKAGE '"BOOTTRAN") EVAL fn setCurrentPackage callingPackage result @@ -205,22 +196,23 @@ STEVAL string== STTOMC string== callingPackage := _*PACKAGE_* IN_-PACKAGE '"BOOTTRAN" - $GenVarCounter:local := 0 + $GenVarCounter := 0 a:= shoeTransformString [string] result := bStreamPackageNull a => nil - shoePCompile car a + shoePCompile first a setCurrentPackage callingPackage result shoeCompileTrees s== while not bStreamNull s repeat - shoeCompile car s - s:=cdr s - + shoeCompile first s + s := rest s + +shoerCompile: %Ast -> %Thing shoeCompile fn== - fn is ['DEFUN,name,bv,:body]=> + fn is ['DEFUN,name,bv,:body] => COMPILE (name,['LAMBDA,bv,:body]) EVAL fn @@ -231,7 +223,9 @@ shoeTransform str== shoeTransformString s== shoeTransform shoeInclude bAddLineNumber(s,bIgen 0) -shoeTransformStream s==shoeTransformString bRgen s + +shoeTransformStream s == + shoeTransformString bRgen s -- shoeTransform shoeInclude bAddLineNumber(bRgen s,bIgen 0) shoeTransformToConsole str== @@ -245,75 +239,76 @@ shoeTransformToFile(fn,str)== bNext(function shoeLineToks, str))) shoeConsoleItem (str)== - dq:=CAR str - shoeConsoleLines shoeDQlines dq - cons(shoeParseTrees dq,CDR str) - -bFileNext(fn,s)==bDelay(function bFileNext1,[fn,s]) + dq := first str + shoeConsoleLines shoeDQlines dq + cons(shoeParseTrees dq, rest str) + +bFileNext(fn,s) == + bDelay(function bFileNext1,[fn,s]) bFileNext1(fn,s)== - bStreamNull s=> ["nullstream"] - dq:=CAR s - shoeFileLines(shoeDQlines dq,fn) - bAppend(shoeParseTrees dq,bFileNext(fn,cdr s)) + bStreamNull s=> ["nullstream"] + dq := first s + shoeFileLines(shoeDQlines dq,fn) + bAppend(shoeParseTrees dq,bFileNext(fn,rest s)) shoeParseTrees dq== - toklist := dqToList dq - null toklist => [] - shoeOutParse toklist + toklist := dqToList dq + null toklist => [] + shoeOutParse toklist shoeTreeConstruct (str)== - cons(shoeParseTrees CAR str,CDR str) + [shoeParseTrees first str, :rest str] shoeDQlines dq== - a:= CDAAR shoeLastTokPosn dq - b:= CDAAR shoeFirstTokPosn dq - streamTake (a-b+1,CAR shoeFirstTokPosn dq) + a:= CDAAR shoeLastTokPosn dq + b:= CDAAR shoeFirstTokPosn dq + streamTake (a-b+1,first shoeFirstTokPosn dq) streamTake(n,s)== - if bStreamNull s - then nil - else if EQL(n,0) - then nil - else cons(car s,streamTake(n-1,cdr s)) + bStreamNull s => nil + n=0 => nil + [first s,:streamTake(n-1, rest s)] shoeFileLines (lines,fn) == - shoeFileLine( '" ",fn) - for line in lines repeat shoeFileLine (shoeAddComment line,fn) - shoeFileLine ('" ",fn) + shoeFileLine( '" ",fn) + for line in lines repeat + shoeFileLine (shoeAddComment line,fn) + shoeFileLine ('" ",fn) shoeConsoleLines lines == - shoeConsole '" " - for line in lines repeat shoeConsole shoeAddComment line - shoeConsole '" " + shoeConsole '" " + for line in lines repeat + shoeConsole shoeAddComment line + shoeConsole '" " shoeFileLine(x, stream) == WRITE_-LINE(x, stream) x shoeFileTrees(s,st)== - while not bStreamNull s repeat - a:=CAR s - if EQCAR (a,"+LINE") - then shoeFileLine(CADR a,st) - else - REALLYPRETTYPRINT(a,st) - TERPRI st - s:=CDR s + while not bStreamNull s repeat + a:= first s + if EQCAR (a,"+LINE") + then shoeFileLine(CADR a,st) + else + REALLYPRETTYPRINT(a,st) + TERPRI st + s:= rest s shoePPtoFile(x, stream) == - SHOENOTPRETTYPRINT(x, stream) - x + SHOENOTPRETTYPRINT(x, stream) + x shoeConsoleTrees s == - while not bStreamPackageNull s repeat --- while not bStreamNull s repeat - fn:=stripm(CAR s,_*PACKAGE_*,FIND_-PACKAGE '"BOOTTRAN") - REALLYPRETTYPRINT fn - s:=CDR s + while not bStreamPackageNull s repeat + fn:=stripm(first s,_*PACKAGE_*,FIND_-PACKAGE '"BOOTTRAN") + REALLYPRETTYPRINT fn + s:= rest s -shoeAddComment l== CONCAT('"; ",CAR l) +shoeAddComment l== + strconc('"; ", first l) ++ Generate an import declaration for `op' as equivalent of the ++ foreign signature `sig'. Here, `foreign' operationally means that @@ -350,34 +345,31 @@ genImportDeclaration(op, sig) == fatalError '"import declaration not implemented for this Lisp" shoeOutParse stream == - $inputStream :local:= stream - $stack:local :=nil - $stok:local := nil - $ttok:local := nil - $op:local :=nil - $wheredefs:local:=nil - $typings:local:=nil - $returns:local :=nil - $bpCount:local:=0 - $bpParenCount:local:=0 - bpFirstTok() - found:=try bpOutItem() catch TRAPPOINT - if found="TRAPPED" - then nil - else if not bStreamNull $inputStream - then - bpGeneralErrorHere() - nil - else if null $stack - then - bpGeneralErrorHere() - nil - else CAR $stack + $inputStream := stream + $stack := [] + $stok := nil + $ttok := nil + $op :=nil + $wheredefs := [] + $typings := [] + $returns := [] + $bpCount := 0 + $bpParenCount := 0 + bpFirstTok() + found := try bpOutItem() catch TRAPPOINT + found = "TRAPPED" => nil + not bStreamNull $inputStream => + bpGeneralErrorHere() + nil + null $stack => + bpGeneralErrorHere() + nil + first $stack ++ Generate a global signature declaration for symbol `n'. genDeclaration(n,t) == t is ["Mapping",valType,argTypes] => - if bfTupleP argTypes then argTypes := cdr argTypes + if bfTupleP argTypes then argTypes := rest argTypes if not null argTypes and SYMBOLP argTypes then argTypes := [argTypes] ["DECLAIM",["FTYPE",["FUNCTION",argTypes,valType],n]] @@ -398,221 +390,165 @@ translateToplevelExpression expr == first expr' bpOutItem()== - $op := nil - bpComma() or bpTrap() - b:=bpPop1() - EQCAR(b,"TUPLE")=> bpPush cdr b - EQCAR(b,"+LINE")=> bpPush [ b ] - b is ["L%T",l,r] and IDENTP l => - bpPush [["DEFPARAMETER",l,r]] - case b of - Signature(op,t) => - bpPush [genDeclaration(op,t)] - - Module(m) => - bpPush [shoeCompileTimeEvaluation ["PROVIDE", m]] - - Import(m) => - bpPush [["IMPORT-MODULE", m]] - - ImportSignature(x, sig) => - bpPush genImportDeclaration(x, sig) - - TypeAlias(lhs, rhs) => - bpPush [genTypeAlias(lhs,rhs)] - - ConstantDefinition(n, e) => - bpPush [["DEFCONSTANT", n, e]] - - otherwise => - bpPush [translateToplevelExpression b] - ---shoeStartsAt (sz,name,stream)== --- bStreamNull stream => ['nullstream] --- a:=CAAR stream --- if #a<sz --- then shoeStartsAt(sz,name,CDR stream) --- else if SUBSTRING(a,0,sz)=name and (#a>sz and not shoeIdChar(a.sz)) --- then stream --- else shoeStartsAt(sz,name,CDR stream) - ---FC(name,fn)== --- $bfClamming:local:=false --- $GenVarCounter:local := 0 --- infn:=shoeAddbootIfNec fn --- shoeOpenInputFile(a,infn,shoeFindName(fn,name, a)) - ---shoeFindName(fn,name,a)== --- shoeFindAndDoSomething(FUNCTION shoeCompile,fn,name,a) ---shoeTransform1 str== --- bNext(function shoeTreeConstruct, --- streamTake(1, bNext(function shoePileInsert, --- bNext(function shoeLineToks, str)))) - ---BOOT_-DO_-SOMETHING_-TO_-DEFINITION_-FROM_-FILE(fun,fn,symbol)== --- $bfClamming:local:=false --- infn:=shoeAddbootIfNec NAMESTRING fn --- name:=PNAME symbol --- shoeOpenInputFile(a,infn,shoeFindAndDoSomething(fun,fn,name, a)) - ---shoeFindAndDoSomething(fun,fn,name,a)== --- if null a --- then shoeNotFound fn --- else --- b:=shoeStartsAt(#name,name, shoeInclude --- bAddLineNumber(bRgen a,bIgen 0)) --- if bStreamNull b --- then shoeConsole CONCAT (name,'" not found in ",fn) --- else --- $GenVarCounter:local := 0 --- shoeLoop(fun,shoeTransform1 b) - ---BOOT_-COMPILE_-DEFINITION_-FROM_-FILE(fn,symbol)== --- BOOT_-DO_-SOMETHING_-TO_-DEFINITION_-FROM_-FILE --- (FUNCTION shoeCompile,fn,symbol) - ---BOOT_-EVAL_-DEFINITION_-FROM_-FILE(fn,symbol)== --- BOOT_-DO_-SOMETHING_-TO_-DEFINITION_-FROM_-FILE --- (FUNCTION EVAL,fn,symbol) - ---BOOT_-PRINT_-DEFINITION_-FROM_-FILE(fn,symbol)== --- BOOT_-DO_-SOMETHING_-TO_-DEFINITION_-FROM_-FILE --- (FUNCTION REALLYPRETTYPRINT,fn,symbol) - ---shoeLoop(fun, s)== --- while not bStreamNull s repeat --- FUNCALL(fun, car s) --- s:=cdr s - -shoeAddbootIfNec s==shoeAddStringIfNec('".boot",s) - -shoeRemovebootIfNec s==shoeRemoveStringIfNec('".boot",s) + $op := nil + bpComma() or bpTrap() + b:=bpPop1() + EQCAR(b,"TUPLE")=> bpPush rest b + EQCAR(b,"+LINE")=> bpPush [ b ] + b is ["L%T",l,r] and IDENTP l => + bpPush [["DEFPARAMETER",l,r]] + case b of + Signature(op,t) => + bpPush [genDeclaration(op,t)] + + Module(m) => + bpPush [shoeCompileTimeEvaluation ["PROVIDE", m]] + + Import(m) => + bpPush [["IMPORT-MODULE", m]] + + ImportSignature(x, sig) => + bpPush genImportDeclaration(x, sig) + + TypeAlias(lhs, rhs) => + bpPush [genTypeAlias(lhs,rhs)] + + ConstantDefinition(n, e) => + bpPush [["DEFCONSTANT", n, e]] + + otherwise => + bpPush [translateToplevelExpression b] + +shoeAddbootIfNec s == + shoeAddStringIfNec('".boot",s) + +shoeRemovebootIfNec s == + shoeRemoveStringIfNec('".boot",s) + shoeAddStringIfNec(str,s)== - a:=STRPOS(str,s,0,nil) - if null a - then CONCAT(s,str) - else s + a:=STRPOS(str,s,0,nil) + a=nil => strconc(s,str) + s shoeRemoveStringIfNec(str,s)== - a:=STRPOS(str,s,0,nil) - if null a - then s - else SUBSTRING(s,0,a) + a := STRPOS(str,s,0,nil) + a = nil => s + SUBSTRING(s,0,a) -- DEFUSE prints the definitions not used and the words used and -- not defined in the input file and common lisp. DEFUSE fn== - infn:=CONCAT(fn,'".boot") + infn := strconc(fn,'".boot") shoeOpenInputFile(a,infn,shoeDfu(a,fn)) shoeDfu(a,fn)== - if null a - then shoeNotFound fn - else - $lispWordTable:local :=MAKE_-HASHTABLE ("EQ") - DO_-SYMBOLS(i(FIND_-PACKAGE "LISP"),HPUT($lispWordTable,i,true)) - $bootDefined:local :=MAKE_-HASHTABLE "EQ" - $bootUsed:local :=MAKE_-HASHTABLE "EQ" - $bootDefinedTwice:local:=nil - $GenVarCounter:local :=0 - $bfClamming:local:=false - shoeDefUse shoeTransformStream a - out:=CONCAT(fn,'".defuse") - shoeOpenOutputFile(stream,out,shoeReport stream) - out + a=nil => shoeNotFound fn + $lispWordTable :=MAKE_-HASHTABLE ("EQ") + DO_-SYMBOLS(i(FIND_-PACKAGE "LISP"),HPUT($lispWordTable,i,true)) + $bootDefined :=MAKE_-HASHTABLE "EQ" + $bootUsed :=MAKE_-HASHTABLE "EQ" + $bootDefinedTwice := nil + $GenVarCounter := 0 + $bfClamming := false + shoeDefUse shoeTransformStream a + out := strconc(fn,'".defuse") + shoeOpenOutputFile(stream,out,shoeReport stream) + out shoeReport stream== - shoeFileLine('"DEFINED and not USED",stream) - a:=[i for i in HKEYS $bootDefined | not GETHASH(i,$bootUsed)] - bootOut(SSORT a,stream) - shoeFileLine('" ",stream) - shoeFileLine('"DEFINED TWICE",stream) - bootOut(SSORT $bootDefinedTwice,stream) - shoeFileLine('" ",stream) - shoeFileLine('"USED and not DEFINED",stream) - a:=[i for i in HKEYS $bootUsed | - not GETHASH(i,$bootDefined)] - for i in SSORT a repeat - b:=CONCAT(PNAME i,'" is used in ") - bootOutLines( SSORT GETHASH(i,$bootUsed),stream,b) + shoeFileLine('"DEFINED and not USED",stream) + a:=[i for i in HKEYS $bootDefined | not GETHASH(i,$bootUsed)] + bootOut(SSORT a,stream) + shoeFileLine('" ",stream) + shoeFileLine('"DEFINED TWICE",stream) + bootOut(SSORT $bootDefinedTwice,stream) + shoeFileLine('" ",stream) + shoeFileLine('"USED and not DEFINED",stream) + a:=[i for i in HKEYS $bootUsed | + not GETHASH(i,$bootDefined)] + for i in SSORT a repeat + b := strconc(PNAME i,'" is used in ") + bootOutLines( SSORT GETHASH(i,$bootUsed),stream,b) shoeDefUse(s)== - while not bStreamPackageNull s repeat - defuse([],CAR s) - s:=CDR s + while not bStreamPackageNull s repeat + defuse([],first s) + s:=rest s defuse(e,x)== - x:=stripm(x,_*PACKAGE_*,FIND_-PACKAGE '"BOOTTRAN") - $used:local:=nil - [nee,niens]:= - x is ['DEFUN,name,bv,:body] => [name,['LAMBDA,bv,:body]] - x is ['DEFMACRO,name,bv,:body] => [name,['LAMBDA,bv,:body]] - x is ["EVAL_-WHEN",.,["SETQ",id,exp]]=>[id,exp] - x is ["SETQ",id,exp]=>[id,exp] - ["TOP-LEVEL", x] - if GETHASH(nee,$bootDefined) - then - $bootDefinedTwice:= - nee="TOP-LEVEL"=> $bootDefinedTwice - cons(nee,$bootDefinedTwice) - else HPUT($bootDefined,nee,true) - defuse1 (e,niens) - for i in $used repeat - HPUT($bootUsed,i,cons(nee,GETHASH(i,$bootUsed))) + x:=stripm(x,_*PACKAGE_*,FIND_-PACKAGE '"BOOTTRAN") + $used :=nil + [nee,niens]:= + x is ['DEFUN,name,bv,:body] => [name,['LAMBDA,bv,:body]] + x is ['DEFMACRO,name,bv,:body] => [name,['LAMBDA,bv,:body]] + x is ["EVAL_-WHEN",.,["SETQ",id,exp]]=>[id,exp] + x is ["SETQ",id,exp]=>[id,exp] + ["TOP-LEVEL", x] + if GETHASH(nee,$bootDefined) + then + $bootDefinedTwice:= + nee="TOP-LEVEL"=> $bootDefinedTwice + cons(nee,$bootDefinedTwice) + else HPUT($bootDefined,nee,true) + defuse1 (e,niens) + for i in $used repeat + HPUT($bootUsed,i,cons(nee,GETHASH(i,$bootUsed))) defuse1(e,y)== - ATOM y => - IDENTP y => - $used:= - MEMQ(y,e)=>$used - MEMQ(y,$used)=>$used - defusebuiltin y =>$used - UNION([y],$used) - [] - y is ["LAMBDA",a,:b]=> defuse1 (append(unfluidlist a,e),b) - y is ["PROG",a,:b]=> - [dol,ndol]:=defSeparate a - for i in dol repeat - HPUT($bootDefined,i,true) - defuse1 (append(ndol,e),b) - y is ["QUOTE",:a] => [] - y is ["+LINE",:a] => [] - for i in y repeat defuse1(e,i) + atom y => + IDENTP y => + $used:= + MEMQ(y,e)=>$used + MEMQ(y,$used)=>$used + defusebuiltin y =>$used + UNION([y],$used) + [] + y is ["LAMBDA",a,:b]=> defuse1 (append(unfluidlist a,e),b) + y is ["PROG",a,:b]=> + [dol,ndol]:=defSeparate a + for i in dol repeat + HPUT($bootDefined,i,true) + defuse1 (append(ndol,e),b) + y is ["QUOTE",:a] => [] + y is ["+LINE",:a] => [] + for i in y repeat defuse1(e,i) defSeparate x== - if null x - then [[],[]] - else - f:=car x - [x1,x2]:=defSeparate cdr x - if bfBeginsDollar f - then [cons(f,x1),x2] - else [x1,cons(f,x2)] + null x => [[],[]] + f := first x + [x1,x2] := defSeparate rest x + bfBeginsDollar f => [[f,:x1],x2] + [x1,cons(f,x2)] + unfluidlist x== - NULL x => [] - ATOM x=> [x] - x is ["&REST",y]=> [y] - cons(car x,unfluidlist cdr x) + NULL x => [] + atom x=> [x] + x is ["&REST",y]=> [y] + cons(first x,unfluidlist rest x) -defusebuiltin x== GETHASH(x,$lispWordTable) +defusebuiltin x == + GETHASH(x,$lispWordTable) bootOut (l,outfn)== - for i in l repeat shoeFileLine (CONCAT ('" ",PNAME i),outfn) + for i in l repeat shoeFileLine (CONCAT ('" ",PNAME i),outfn) -CLESSP(s1,s2)==not(SHOEGREATERP(s1,s2)) -SSORT l == SORT(l,function CLESSP) +CLESSP(s1,s2)== + not(SHOEGREATERP(s1,s2)) + +SSORT l == + SORT(l,function CLESSP) bootOutLines(l,outfn,s)== if null l then shoeFileLine(s,outfn) else - a:=PNAME car l + a:=PNAME first l if #s +#a > 70 then shoeFileLine(s,outfn) bootOutLines(l,outfn,'" ") - else bootOutLines(cdr l,outfn,CONCAT(s,'" ",a)) + else bootOutLines(rest l,outfn,CONCAT(s,'" ",a)) -- (xref "fn") produces a cross reference listing in "fn.xref" @@ -627,12 +563,12 @@ shoeXref(a,fn)== if null a then shoeNotFound fn else - $lispWordTable:local :=MAKE_-HASHTABLE ("EQ") + $lispWordTable :=MAKE_-HASHTABLE ("EQ") DO_-SYMBOLS(i(FIND_-PACKAGE "LISP"),HPUT($lispWordTable,i,true)) - $bootDefined:local :=MAKE_-HASHTABLE "EQ" - $bootUsed:local :=MAKE_-HASHTABLE "EQ" - $GenVarCounter:local :=0 - $bfClamming:local:=false + $bootDefined :=MAKE_-HASHTABLE "EQ" + $bootUsed :=MAKE_-HASHTABLE "EQ" + $GenVarCounter :=0 + $bfClamming :=false shoeDefUse shoeTransformStream a out:=CONCAT(fn,'".xref") shoeOpenOutputFile(stream,out,shoeXReport stream) @@ -640,21 +576,21 @@ shoeXref(a,fn)== shoeXReport stream== - shoeFileLine('"USED and where DEFINED",stream) - c:=SSORT HKEYS $bootUsed - for i in c repeat - a:=CONCAT(PNAME i,'" is used in ") - bootOutLines( SSORT GETHASH(i,$bootUsed),stream,a) - ---FC (name,fn)== shoeGeneralFC(function BOOT,name,fn) + shoeFileLine('"USED and where DEFINED",stream) + c:=SSORT HKEYS $bootUsed + for i in c repeat + a:=CONCAT(PNAME i,'" is used in ") + bootOutLines( SSORT GETHASH(i,$bootUsed),stream,a) -FBO (name,fn)== shoeGeneralFC(function BO,name,fn) +FBO (name,fn)== + shoeGeneralFC(function BO,name,fn) -FEV(name,fn)== shoeGeneralFC(function EVAL_-BOOT_-FILE,name,fn) +FEV(name,fn)== + shoeGeneralFC(function EVAL_-BOOT_-FILE,name,fn) shoeGeneralFC(f,name,fn)== - $bfClamming:local:=false - $GenVarCounter:local := 0 + $bfClamming :=false + $GenVarCounter := 0 infn:=shoeAddbootIfNec fn a:= shoeOpenInputFile(a,infn,shoeFindName2(fn,name, a)) filename:= if # name > 8 then SUBSTRING(name,0,8) else name @@ -662,14 +598,14 @@ shoeGeneralFC(f,name,fn)== nil shoeFindName2(fn,name,a)== - lines:=shoeFindLines(fn,name,a) - lines => - filename:= if # name > 8 then SUBSTRING(name,0,8) else name - filename := CONCAT ('"/tmp/",filename,'".boot") - shoeOpenOutputFile(stream, filename, - for line in lines repeat shoeFileLine (line,stream)) - true - false + lines:=shoeFindLines(fn,name,a) + lines => + filename:= if # name > 8 then SUBSTRING(name,0,8) else name + filename := CONCAT ('"/tmp/",filename,'".boot") + shoeOpenOutputFile(stream, filename, + for line in lines repeat shoeFileLine (line,stream)) + true + false shoeTransform2 str== bNext(function shoeItem, @@ -677,39 +613,16 @@ shoeTransform2 str== bNext(function shoeLineToks, str)))) shoeItem (str)== - dq:=CAR str - cons([[CAR line for line in shoeDQlines dq]],CDR str) - ---shoeLines lines == [CAR line for line in lines] - ---shoeFindAndDoSomething2(fun,fn,name,a)== --- if null a --- then shoeNotFound fn --- else --- [lines,b]:=shoePackageStartsAt([],#name,name, shoeInclude --- bAddLineNumber(bRgen a,bIgen 0)) --- if bStreamNull b --- then --- shoeConsole CONCAT (name,'" not found in ",fn) --- [] --- else --- if null lines --- then shoeConsole '")package not found" --- $GenVarCounter:local := 0 --- shoeLoopPackage(fun,shoeTransform2 b,lines) - ---shoeLoopPackage(fun, s,lines)== --- while not bStreamNull s repeat --- FUNCALL(fun, append (reverse lines,car s)) --- s:=cdr s --- true + dq:=first str + cons([[first line for line in shoeDQlines dq]],rest str) + stripm (x,pk,bt)== - ATOM x => - IDENTP x => - SYMBOL_-PACKAGE x = bt => INTERN(PNAME x,pk) - x - x - CONS(stripm(CAR x,pk,bt),stripm(CDR x,pk,bt)) + atom x => + IDENTP x => + SYMBOL_-PACKAGE x = bt => INTERN(PNAME x,pk) + x + x + CONS(stripm(first x,pk,bt),stripm(rest x,pk,bt)) shoePCompile fn== fn:=stripm(fn,_*PACKAGE_*,FIND_-PACKAGE '"BOOTTRAN") @@ -718,65 +631,65 @@ shoePCompile fn== EVAL fn FC(name,fn)== - $GenVarCounter:local := 0 + $GenVarCounter := 0 infn:=shoeAddbootIfNec fn shoeOpenInputFile(a,infn,shoeFindName(fn,name, a)) shoeFindName(fn,name,a)== - lines:=shoeFindLines(fn,name,a) - shoePCompileTrees shoeTransformString lines + lines:=shoeFindLines(fn,name,a) + shoePCompileTrees shoeTransformString lines shoePCompileTrees s== - while not bStreamPackageNull s repeat - REALLYPRETTYPRINT shoePCompile car s - s:=cdr s + while not bStreamPackageNull s repeat + REALLYPRETTYPRINT shoePCompile first s + s := rest s bStreamPackageNull s== - a := _*PACKAGE_* - IN_-PACKAGE '"BOOTTRAN" - b:=bStreamNull s - setCurrentPackage a - b + a := _*PACKAGE_* + IN_-PACKAGE '"BOOTTRAN" + b:=bStreamNull s + setCurrentPackage a + b PSTTOMC string== - $GenVarCounter:local := 0 - shoePCompileTrees shoeTransformString string + $GenVarCounter := 0 + shoePCompileTrees shoeTransformString string BOOTLOOP ()== - a:=READ_-LINE() - #a=0=> - WRITE_-LINE '"Boot Loop; to exit type ] " - BOOTLOOP() - b:=shoePrefix? ('")console",a) - b => - stream:= _*TERMINAL_-IO_* - PSTTOMC bRgen stream - BOOTLOOP() - a.0='"]".0 => nil - PSTTOMC [a] - BOOTLOOP() + a:=READ_-LINE() + #a=0=> + WRITE_-LINE '"Boot Loop; to exit type ] " + BOOTLOOP() + b:=shoePrefix? ('")console",a) + b => + stream:= _*TERMINAL_-IO_* + PSTTOMC bRgen stream + BOOTLOOP() + a.0='"]".0 => nil + PSTTOMC [a] + BOOTLOOP() BOOTPO ()== - a:=READ_-LINE() - #a=0=> - WRITE_-LINE '"Boot Loop; to exit type ] " - BOOTPO() - b:=shoePrefix? ('")console",a) - b => - stream:= _*TERMINAL_-IO_* - PSTOUT bRgen stream - BOOTPO() - a.0='"]".0 => nil - PSTOUT [a] - BOOTPO() + a:=READ_-LINE() + #a=0=> + WRITE_-LINE '"Boot Loop; to exit type ] " + BOOTPO() + b:=shoePrefix? ('")console",a) + b => + stream:= _*TERMINAL_-IO_* + PSTOUT bRgen stream + BOOTPO() + a.0='"]".0 => nil + PSTOUT [a] + BOOTPO() PSTOUT string== - callingPackage := _*PACKAGE_* - IN_-PACKAGE '"BOOTTRAN" - $GenVarCounter:local := 0 - result := shoeConsoleTrees shoeTransformString string - setCurrentPackage callingPackage - result + callingPackage := _*PACKAGE_* + IN_-PACKAGE '"BOOTTRAN" + $GenVarCounter := 0 + result := shoeConsoleTrees shoeTransformString string + setCurrentPackage callingPackage + result defaultBootToLispFile file == @@ -796,6 +709,7 @@ compileBootHandler(progname, options, file) == associateRequestWithFileType(Option '"translate", '"boot", function translateBootFile) + associateRequestWithFileType(Option '"compile", '"boot", function compileBootHandler) @@ -806,7 +720,7 @@ associateRequestWithFileType(Option '"compile", '"boot", ++ over directory specified at configuration time. systemRootDirectory() == dir := ASSOC(Option '"system", %systemOptions()) => - ensureTrailingSlash cdr dir + ensureTrailingSlash rest dir $systemInstallationDirectory ++ Returns the directory containing the core runtime support |