aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/ChangeLog4
-rw-r--r--src/boot/ast.boot25
-rw-r--r--src/boot/translator.boot760
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