diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/ChangeLog | 15 | ||||
| -rw-r--r-- | src/boot/Makefile.in | 4 | ||||
| -rw-r--r-- | src/boot/ast.boot | 39 | ||||
| -rw-r--r-- | src/boot/parser.boot | 4 | ||||
| -rw-r--r-- | src/boot/strap/ast.clisp | 53 | ||||
| -rw-r--r-- | src/boot/strap/parser.clisp | 2 | ||||
| -rw-r--r-- | src/boot/strap/translator.clisp | 45 | ||||
| -rw-r--r-- | src/boot/translator.boot | 28 | ||||
| -rw-r--r-- | src/interp/nrunopt.boot | 2 | ||||
| -rw-r--r-- | src/lisp/core.lisp.in | 19 |
10 files changed, 155 insertions, 56 deletions
diff --git a/src/ChangeLog b/src/ChangeLog index 87a954f1..0c170808 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,5 +1,20 @@ 2009-05-10 Gabriel Dos Reis <gdr@cs.tamu.edu> + Cope with SBCL-1.0.28 improvements. + * boot/translator.boot (translateToplevel): Load imported modules. + * boot/ast.boot ($constantIdentifiers): New. + ($activeNamespace): Likewise. + (bfSimpleDefinition): Likewise. + (isDynamicVariable): Likewise. + (shoeCompTran1): Tidy. Use it. + * boot/parser.boot (bpSimpleDefinitionTail): Use bfSimpleDefinition. + * boot/Makefile.in (stage1/%.clisp): Specify load directory. + (stage2/%.clisp): Likewise. + * lisp/core.lisp.in (startCompileDuration): Export. + (endCompileDuration): Likewise. + +2009-05-10 Gabriel Dos Reis <gdr@cs.tamu.edu> + * interp/nrunopt.boot (makeGoGetSlot): Adjust call to makeCompactSigCode. (makeCompactDirect1): Likewise. diff --git a/src/boot/Makefile.in b/src/boot/Makefile.in index c6fad676..357874ae 100644 --- a/src/boot/Makefile.in +++ b/src/boot/Makefile.in @@ -148,7 +148,7 @@ stage1/bootsys$(EXEEXT): $(stage1_boot_objects) --output=$@ --load-directory=stage1 $(stage1_boot_objects) stage1/%.clisp: %.boot strap/stamp stage1/.started - strap/bootsys -- --translate --output=$@ $< + strap/bootsys -- --translate --load-directory=stage1 --output=$@ $< ## @@ -175,7 +175,7 @@ stage2/bootsys$(EXEEXT): $(stage2_boot_objects) --output=$@ --load-directory=stage2 $(stage2_boot_objects) stage2/%.clisp: %.boot stage1/stamp stage2/.started - stage1/bootsys -- --translate --output=$@ $< + stage1/bootsys -- --translate --load-directory=stage2 --output=$@ $< ## ## Generic rules for compiling FASLs diff --git a/src/boot/ast.boot b/src/boot/ast.boot index 0e42ac62..b49f149f 100644 --- a/src/boot/ast.boot +++ b/src/boot/ast.boot @@ -47,6 +47,14 @@ module ast ++ translated with the obvious semantics, e.g. no caching. $bfClamming := false +++ List of identifiers defined as constants in the current +++ translation unit. +$constantIdentifiers := nil + +++ When non-nil holds the scope nominated in the most recent +++ namespace definition. +$activeNamespace := nil + --% Basic types used in Boot codes. %Thing <=> true @@ -193,7 +201,17 @@ bfColonAppend(x,y) == bfDefinition: (%Thing,%Thing,%Thing) -> %List bfDefinition(bflhsitems, bfrhs,body) == ['DEF,bflhsitems,bfrhs,body] + +bfSimpleDefinition: (%Thing,%Thing) -> %Thing +bfSimpleDefinition(lhs,rhs) == + if atom lhs then + $constantIdentifiers := [lhs,:$constantIdentifiers] + else if lhs is ["%Signature",id,.] then + $constantIdentifiers := [id,:$constantIdentifiers] + ConstantDefinition(lhs,rhs) + + bfMDefinition: (%Thing,%Thing,%Thing) -> %List bfMDefinition(bflhsitems, bfrhs,body) == bfMDef('MDEF,bflhsitems,bfrhs,body) @@ -946,14 +964,25 @@ shoeATOMs x== else if atom x then [x] else append(shoeATOMs first x,shoeATOMs rest x) + +++ Return true if `x' is an identifier name that designates a +++ dynamic (e.g. Lisp special) variable. +isDynamicVariable x == + IDENTP x and bfBeginsDollar x => + MEMQ(x,$constantIdentifiers) => false + CONSTANTP x => false + BOUNDP x or null $activeNamespace => true + y := FIND_-SYMBOL(STRING x,$activeNamespace) => not CONSTANTP y + true + false shoeCompTran1 x== atom x=> - IDENTP x and bfBeginsDollar x=> - $dollarVars:= - MEMQ(x,$dollarVars)=>$dollarVars - cons(x,$dollarVars) - nil + isDynamicVariable x => + $dollarVars:= + MEMQ(x,$dollarVars)=>$dollarVars + cons(x,$dollarVars) + nil U:=car x EQ(U,"QUOTE")=>nil x is ["L%T",l,r]=> diff --git a/src/boot/parser.boot b/src/boot/parser.boot index b881ffe2..68300d52 100644 --- a/src/boot/parser.boot +++ b/src/boot/parser.boot @@ -1,6 +1,6 @@ -- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -- All rights reserved. --- Copyright (C) 2007-2008, Gabriel Dos Reis. +-- Copyright (C) 2007-2009, Gabriel Dos Reis. -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without @@ -883,7 +883,7 @@ bpDDef() == bpName() and bpDefTail() bpSimpleDefinitionTail() == bpEqKey "DEF" and (bpWhere() or bpTrap()) - and bpPush ConstantDefinition(bpPop2(), bpPop1()) + and bpPush bfSimpleDefinition(bpPop2(), bpPop1()) ++ Parse the remaining of a compound definition. bpCompoundDefinitionTail() == diff --git a/src/boot/strap/ast.clisp b/src/boot/strap/ast.clisp index 62028541..bd54f16f 100644 --- a/src/boot/strap/ast.clisp +++ b/src/boot/strap/ast.clisp @@ -7,6 +7,10 @@ (DEFPARAMETER |$bfClamming| NIL) +(DEFPARAMETER |$constantIdentifiers| NIL) + +(DEFPARAMETER |$activeNamespace| NIL) + (DEFTYPE |%Thing| () 'T) (DEFTYPE |%Boolean| () 'BOOLEAN) @@ -214,6 +218,31 @@ (DEFUN |bfDefinition| (|bflhsitems| |bfrhs| |body|) (LIST 'DEF |bflhsitems| |bfrhs| |body|)) +(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing|) |%Thing|) + |bfSimpleDefinition|)) + +(DEFUN |bfSimpleDefinition| (|lhs| |rhs|) + (PROG (|ISTMP#2| |id| |ISTMP#1|) + (DECLARE (SPECIAL |$constantIdentifiers|)) + (RETURN + (PROGN + (COND + ((ATOM |lhs|) + (SETQ |$constantIdentifiers| + (CONS |lhs| |$constantIdentifiers|))) + ((AND (CONSP |lhs|) (EQ (CAR |lhs|) '|%Signature|) + (PROGN + (SETQ |ISTMP#1| (CDR |lhs|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |id| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) + (EQ (CDR |ISTMP#2|) NIL)))))) + (SETQ |$constantIdentifiers| + (CONS |id| |$constantIdentifiers|)))) + (|ConstantDefinition| |lhs| |rhs|))))) + (DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing| |%Thing|) |%List|) |bfMDefinition|)) @@ -1622,6 +1651,21 @@ ((ATOM |x|) (LIST |x|)) ('T (APPEND (|shoeATOMs| (CAR |x|)) (|shoeATOMs| (CDR |x|)))))) +(DEFUN |isDynamicVariable| (|x|) + (PROG (|y|) + (DECLARE (SPECIAL |$activeNamespace| |$constantIdentifiers|)) + (RETURN + (COND + ((AND (IDENTP |x|) (|bfBeginsDollar| |x|)) + (COND + ((MEMQ |x| |$constantIdentifiers|) NIL) + ((CONSTANTP |x|) NIL) + ((OR (BOUNDP |x|) (NULL |$activeNamespace|)) T) + ((SETQ |y| (FIND-SYMBOL (STRING |x|) |$activeNamespace|)) + (NOT (CONSTANTP |y|))) + (#0='T T))) + (#0# NIL))))) + (DEFUN |shoeCompTran1| (|x|) (PROG (|res| |newbindings| |r| |ISTMP#2| |l| |ISTMP#1| U) (DECLARE (SPECIAL |$fluidVars| |$locVars| |$dollarVars|)) @@ -1629,7 +1673,7 @@ (COND ((ATOM |x|) (COND - ((AND (IDENTP |x|) (|bfBeginsDollar| |x|)) + ((|isDynamicVariable| |x|) (SETQ |$dollarVars| (COND ((MEMQ |x| |$dollarVars|) |$dollarVars|) @@ -2203,7 +2247,6 @@ (APPEND |$NativeSimpleDataTypes| '(|void| |string|))) (DEFUN |isSimpleNativeType| (|t|) - (DECLARE (SPECIAL |$NativeSimpleReturnTypes|)) (MEMBER |t| |$NativeSimpleReturnTypes|)) (DECLAIM (FTYPE (FUNCTION (|%Symbol|) |%Symbol|) |coreSymbol|)) @@ -2219,7 +2262,6 @@ (DEFUN |nativeType| (|t|) (PROG (|t'|) - (DECLARE (SPECIAL |$NativeTypeTable|)) (RETURN (COND ((NULL |t|) |t|) @@ -2315,7 +2357,6 @@ (#0# (|unknownNativeTypeError| |t|)))))) (DEFUN |nativeReturnType| (|t|) - (DECLARE (SPECIAL |$NativeSimpleReturnTypes|)) (COND ((MEMBER |t| |$NativeSimpleReturnTypes|) (|nativeType| |t|)) ('T @@ -2325,7 +2366,6 @@ (DEFUN |nativeArgumentType| (|t|) (PROG (|t'| |c| |m|) - (DECLARE (SPECIAL |$NativeSimpleDataTypes|)) (RETURN (COND ((MEMBER |t| |$NativeSimpleDataTypes|) (|nativeType| |t|)) @@ -2508,7 +2548,6 @@ (DEFUN |genGCLnativeTranslation,gclTypeInC| (|x|) (PROG (|ISTMP#3| |ISTMP#2| |ISTMP#1|) - (DECLARE (SPECIAL |$NativeSimpleDataTypes|)) (RETURN (COND ((MEMBER |x| |$NativeSimpleDataTypes|) (SYMBOL-NAME |x|)) @@ -2531,7 +2570,6 @@ (DEFUN |genGCLnativeTranslation,gclArgInC| (|x| |a|) (PROG (|y| |c|) - (DECLARE (SPECIAL |$NativeSimpleDataTypes|)) (RETURN (COND ((MEMBER |x| |$NativeSimpleDataTypes|) |a|) @@ -2625,7 +2663,6 @@ (DEFUN |genECLnativeTranslation,selectDatum| (|x|) (PROG (|y| |c|) - (DECLARE (SPECIAL |$ECLVersionNumber|)) (RETURN (COND ((|isSimpleNativeType| |x|) "") diff --git a/src/boot/strap/parser.clisp b/src/boot/strap/parser.clisp index fc373262..56275620 100644 --- a/src/boot/strap/parser.clisp +++ b/src/boot/strap/parser.clisp @@ -920,7 +920,7 @@ (DEFUN |bpSimpleDefinitionTail| () (AND (|bpEqKey| 'DEF) (OR (|bpWhere|) (|bpTrap|)) - (|bpPush| (|ConstantDefinition| (|bpPop2|) (|bpPop1|))))) + (|bpPush| (|bfSimpleDefinition| (|bpPop2|) (|bpPop1|))))) (DEFUN |bpCompoundDefinitionTail| () (AND (|bpVariable|) (|bpReturnType|) (|bpEqKey| 'DEF) diff --git a/src/boot/strap/translator.clisp b/src/boot/strap/translator.clisp index 32cad87a..b809ddd6 100644 --- a/src/boot/strap/translator.clisp +++ b/src/boot/strap/translator.clisp @@ -84,7 +84,6 @@ (#0# NIL))))) (DEFUN |genOptimizeOptions| (|stream|) - (DECLARE (SPECIAL |$LispOptimizeOptions|)) (REALLYPRETTYPRINT (LIST 'PROCLAIM (LIST 'QUOTE (CONS 'OPTIMIZE |$LispOptimizeOptions|))) @@ -124,12 +123,15 @@ (DEFUN BOOTTOCL (|fn| |out|) (PROG (|result| |callingPackage|) (RETURN - (PROGN - (SETQ |callingPackage| *PACKAGE*) - (IN-PACKAGE "BOOTTRAN") - (SETQ |result| (BOOTTOCLLINES NIL |fn| |out|)) - (|setCurrentPackage| |callingPackage|) - |result|)))) + (UNWIND-PROTECT + (PROGN + (|startCompileDuration|) + (SETQ |callingPackage| *PACKAGE*) + (IN-PACKAGE "BOOTTRAN") + (SETQ |result| (BOOTTOCLLINES NIL |fn| |out|)) + (|setCurrentPackage| |callingPackage|) + |result|) + (|endCompileDuration|))))) (DEFUN BOOTCLAM (|fn| |out|) (DECLARE (SPECIAL |$bfClamming|)) @@ -171,12 +173,15 @@ (DEFUN BOOTTOCLC (|fn| |out|) (PROG (|result| |callingPackage|) (RETURN - (PROGN - (SETQ |callingPackage| *PACKAGE*) - (IN-PACKAGE "BOOTTRAN") - (SETQ |result| (BOOTTOCLCLINES NIL |fn| |out|)) - (|setCurrentPackage| |callingPackage|) - |result|)))) + (UNWIND-PROTECT + (PROGN + (|startCompileDuration|) + (SETQ |callingPackage| *PACKAGE*) + (IN-PACKAGE "BOOTTRAN") + (SETQ |result| (BOOTTOCLCLINES NIL |fn| |out|)) + (|setCurrentPackage| |callingPackage|) + |result|) + (|endCompileDuration|))))) (DEFUN BOOTTOCLCLINES (|lines| |fn| |outfn|) (PROG (|infn|) @@ -602,8 +607,8 @@ (DEFUN |translateToplevel| (|b| |export?|) (PROG (|lhs| |t| |ISTMP#2| |n| |ISTMP#1| |sig| |bfVar#17| |bfVar#16| |xs|) - (DECLARE (SPECIAL |$InteractiveMode| |$foreignsDefsForCLisp| - |$currentModuleName|)) + (DECLARE (SPECIAL |$activeNamespace| |$InteractiveMode| + |$foreignsDefsForCLisp| |$currentModuleName|)) (RETURN (COND ((ATOM |b|) (LIST |b|)) @@ -653,7 +658,9 @@ (SETQ |bfVar#14| (CDR |bfVar#14|)))))))) (|Import| (LET ((|m| (CAR |bfVar#17|))) - (LIST (LIST 'IMPORT-MODULE (STRING |m|))))) + (PROGN + (|bootImport| (STRING |m|)) + (LIST (LIST 'IMPORT-MODULE (STRING |m|)))))) (|ImportSignature| (LET ((|x| (CAR |bfVar#17|)) (|sig| (CADR |bfVar#17|))) @@ -721,7 +728,9 @@ |export?|))))))) (|namespace| (LET ((|n| (CAR |bfVar#17|))) - (LIST (LIST 'IN-PACKAGE (STRING |n|))))) + (PROGN + (SETQ |$activeNamespace| (STRING |n|)) + (LIST (LIST 'IN-PACKAGE (STRING |n|)))))) (T (LIST (|translateToplevelExpression| |b|)))))))))) (DEFUN |bpOutItem| () @@ -1343,7 +1352,6 @@ (DEFUN |getIntermediateLispFile| (|file| |options|) (PROG (|out|) - (DECLARE (SPECIAL |$effectiveFaslType|)) (RETURN (PROGN (SETQ |out| (NAMESTRING (|getOutputPathname| |options|))) @@ -1401,7 +1409,6 @@ (|coreError| "don't know how to load a dynamically linked module")))) (DEFUN |loadSystemRuntimeCore| () - (DECLARE (SPECIAL |$NativeModuleExt|)) (COND ((OR (|%hasFeature| :ECL) (|%hasFeature| :GCL)) NIL) ('T diff --git a/src/boot/translator.boot b/src/boot/translator.boot index 70c5da4e..083c374f 100644 --- a/src/boot/translator.boot +++ b/src/boot/translator.boot @@ -91,11 +91,14 @@ shoeCOMPILE_-FILE lspFileName == BOOTTOCL(fn, out) == - callingPackage := _*PACKAGE_* - IN_-PACKAGE '"BOOTTRAN" - result := BOOTTOCLLINES(nil,fn, out) - setCurrentPackage callingPackage - result + UNWIND_-PROTECT( + PROGN(startCompileDuration(), + callingPackage := _*PACKAGE_*, + IN_-PACKAGE '"BOOTTRAN", + result := BOOTTOCLLINES(nil,fn, out), + setCurrentPackage callingPackage, + result), + endCompileDuration()) ++ (bootclam "filename") translates the file "filename.boot" to ++ the common lisp file "filename.clisp" , producing, for each function @@ -126,11 +129,14 @@ shoeClLines(a,fn,lines,outfn)== ++ the common lisp file "filename.clisp" with the original boot ++ code as comments BOOTTOCLC(fn, out)== - callingPackage := _*PACKAGE_* - IN_-PACKAGE '"BOOTTRAN" - result := BOOTTOCLCLINES(nil, fn, out) - setCurrentPackage callingPackage - result + UNWIND_-PROTECT( + PROGN(startCompileDuration(), + callingPackage := _*PACKAGE_*, + IN_-PACKAGE '"BOOTTRAN", + result := BOOTTOCLCLINES(nil, fn, out), + setCurrentPackage callingPackage, + result), + endCompileDuration()) BOOTTOCLCLINES(lines, fn, outfn)== infn:=shoeAddbootIfNec fn @@ -421,6 +427,7 @@ translateToplevel(b,export?) == :[first translateToplevel(d,true) for d in ds]] Import(m) => + bootImport STRING m [["IMPORT-MODULE", STRING m]] ImportSignature(x, sig) => @@ -445,6 +452,7 @@ translateToplevel(b,export?) == [maybeExportDecl(["DEFPARAMETER",lhs,rhs],export?)] namespace(n) => + $activeNamespace := STRING n [["IN-PACKAGE",STRING n]] otherwise => diff --git a/src/interp/nrunopt.boot b/src/interp/nrunopt.boot index c3aa691f..c0042bf8 100644 --- a/src/interp/nrunopt.boot +++ b/src/interp/nrunopt.boot @@ -558,6 +558,8 @@ dcOpPrint(op,index) == slotNumber = 1 => '"missing" name := $infovec.0.slotNumber atom name => name + name is ["CONS","IDENTITY", + ["FUNCALL", ["dispatchFunction", impl],"$"]] => impl '"looked up" sayBrightly [:formatOpSignature(op,signumList),:namePart, :suffix] index + 1 diff --git a/src/lisp/core.lisp.in b/src/lisp/core.lisp.in index 50fc80b9..489b1db6 100644 --- a/src/lisp/core.lisp.in +++ b/src/lisp/core.lisp.in @@ -61,6 +61,8 @@ "countError" "resetErrorCount" "warn" + "startCompileDuration" + "endCompileDuration" "%ByteArray" "makeByteArray" @@ -105,7 +107,7 @@ "pathBasename" "IMPORT-MODULE" - "BOOT-IMPORT" + "bootImport" "CONCAT" "$EditorProgram" )) @@ -819,7 +821,7 @@ :directory (list (|currentDirectoryName|))))) (unwind-protect (progn - (begin-compile-time) + (|startCompileDuration|) (multiple-value-bind (result warning-p failure-p) #-:ecl (compile-file file :output-file out-file) #+:ecl (compile-file file :output-file out-file :system-p t) @@ -840,7 +842,7 @@ (warning-p (|warn| "Lisp code contained warnings"))) result)) - (end-compile-time))) + (|endCompileDuration|))) (defun |compileLispHandler| (prog-name options in-file) (declare (ignore prog-name)) @@ -979,9 +981,8 @@ (if (compile-time-p) (|importModule| ,module))))) -(defmacro boot-import (module) - `(eval-when (:compile-toplevel) - (|importModule| ,module))) +(defmacro |bootImport| (module) + `(|importModule| ,module)) ;; ;; -*- Feature Tests in Boot -*- @@ -990,11 +991,11 @@ (defun |%hasFeature| (f) (member f *features* :test #'eq)) -(defun begin-compile-time nil +(defun |startCompileDuration| nil (push :open-axiom-compile-time *features*)) -(defun end-compile-time nil - (pop *features*)) +(defun |endCompileDuration| nil + (delete :open-axiom-compile-time *features*)) (defun compile-time-p nil (member :open-axiom-compile-time *features*)) |