diff options
author | dos-reis <gdr@axiomatics.org> | 2008-04-29 20:21:43 +0000 |
---|---|---|
committer | dos-reis <gdr@axiomatics.org> | 2008-04-29 20:21:43 +0000 |
commit | bce316614ee1d8dbb77aff1b6a13c354c16f63ea (patch) | |
tree | 63af5ac89937cab1c29a910f88fa33433ad625ef | |
parent | 7e465ce1b99903491c6132466808c9fa51ae500e (diff) | |
download | open-axiom-bce316614ee1d8dbb77aff1b6a13c354c16f63ea.tar.gz |
cleanup CLisp FFI
-rw-r--r-- | src/ChangeLog | 10 | ||||
-rw-r--r-- | src/boot/strap/ast.clisp | 4 | ||||
-rw-r--r-- | src/boot/strap/includer.clisp | 10 | ||||
-rw-r--r-- | src/boot/strap/translator.clisp | 250 | ||||
-rw-r--r-- | src/boot/translator.boot | 44 | ||||
-rw-r--r-- | src/interp/sys-driver.boot | 4 | ||||
-rw-r--r-- | src/interp/sys-os.boot | 2 | ||||
-rw-r--r-- | src/interp/util.lisp | 1 |
8 files changed, 227 insertions, 98 deletions
diff --git a/src/ChangeLog b/src/ChangeLog index f25b4744..22d89055 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,5 +1,15 @@ 2008-04-29 Gabriel Dos Reis <gdr@cs.tamu.edu> + * interp/util.lisp (build-interpsys): Call %sysInit. + * boot/translator.boot (shoeClLines): Output module finalization. + (shoeClCLines): Likewise. + (genImportDeclaration): Tidy. + (bpOutItem): Likewise. + ($OpenAxiomCoreModuleLoaded): Remove. + * interp/sys-driver.boot: Tidy. + +2008-04-29 Gabriel Dos Reis <gdr@cs.tamu.edu> + * lisp/core.lisp.in: Export %ByteArray and makeByteArray. (CONCAT): Tdiy. * lib/sockio-c.c: Tidy. diff --git a/src/boot/strap/ast.clisp b/src/boot/strap/ast.clisp index c02bb4a7..08a0078f 100644 --- a/src/boot/strap/ast.clisp +++ b/src/boot/strap/ast.clisp @@ -2041,7 +2041,7 @@ (RETURN (COND ((NULL (CDR |x|)) (SETQ |f| (CAR |x|)) - (LIST 'SETQ |f| (LIST 'LIST (LIST 'QUOTE |f|)))) + (LIST 'DEFPARAMETER |f| (LIST 'LIST (LIST 'QUOTE |f|)))) ('T (SETQ |a| (LET ((|bfVar#121| NIL) (|bfVar#120| (CDR |x|)) @@ -2202,7 +2202,7 @@ (COND ((NULL |t|) |t|) ((SETQ |t'| (ASSOC (|coreSymbol| |t|) |$NativeTypeTable|)) - (|bootSymbol| (CDR |t'|))) + (CDR |t'|)) ('T (|fatalError| (CONCAT "unsupported native type: " (SYMBOL-NAME |t|)))))))) diff --git a/src/boot/strap/includer.clisp b/src/boot/strap/includer.clisp index 167e7f2a..f43cbfb8 100644 --- a/src/boot/strap/includer.clisp +++ b/src/boot/strap/includer.clisp @@ -4,6 +4,16 @@ (IN-PACKAGE "BOOTTRAN") +(DEFPARAMETER |%UnknownMode| (LIST '|%UnknownMode|)) + +(DEFPARAMETER |%TranslateMode| (LIST '|%TranslateMode|)) + +(DEFPARAMETER |%CompileMode| (LIST '|%CompileMode|)) + +(DEFPARAMETER |%MakeMode| (LIST '|%MakeMode|)) + +(DEFPARAMETER |$driverMode| |%UnknownMode|) + (DEFUN PNAME (|x|) (COND ((SYMBOLP |x|) (SYMBOL-NAME |x|)) diff --git a/src/boot/strap/translator.clisp b/src/boot/strap/translator.clisp index ba0b894b..59d6acf5 100644 --- a/src/boot/strap/translator.clisp +++ b/src/boot/strap/translator.clisp @@ -385,6 +385,19 @@ (DEFUN |shoeAddComment| (|l|) (CONCAT "; " (CAR |l|))) +(DEFUN |typeNeedsSurrogate| (|t|) + (COND ((|%hasFeature| :GCL) NIL) ((|%hasFeature| :SBCL) NIL) ('T T))) + +(DEFUN |coerceToNativeType| (|x| |t|) + (COND + ((|%hasFeature| :GCL) |x|) + ((|%hasFeature| :SBCL) + (COND + ((EQ |t| '|data|) + (LIST (|bfColonColon| 'SB-IMPL 'VECTOR-SAP) |x|)) + (#0='T |x|))) + (#0# (|fatalError| "don't know how to coerce data to native type")))) + (DEFUN |genImportDeclaration| (|op| |sig|) (PROG (|forwardingFun| |foreignDecl| |n| |args| |s| |t| |m| |ISTMP#2| |op'| |ISTMP#1|) @@ -422,6 +435,8 @@ ((AND (NOT (NULL |s|)) (SYMBOLP |s|)) (SETQ |s| (LIST |s|)))) (COND + ((|typeNeedsSurrogate| |t|) + (|fatalError| "return type shall not need surrogate")) ((|%hasFeature| :GCL) (LIST (LIST 'DEFENTRY |op| (LET ((|bfVar#6| NIL) (|bfVar#5| |s|) @@ -484,7 +499,34 @@ |bfVar#10|)))) (SETQ |bfVar#9| (CDR |bfVar#9|))))))) - |args|))))) + (LET + ((|bfVar#13| NIL) + (|bfVar#11| |args|) (|a| NIL) + (|bfVar#12| |s|) (|x| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#11|) + (PROGN + (SETQ |a| + (CAR |bfVar#11|)) + NIL) + (ATOM |bfVar#12|) + (PROGN + (SETQ |x| + (CAR |bfVar#12|)) + NIL)) + (RETURN + (NREVERSE |bfVar#13|))) + (#2# + (SETQ |bfVar#13| + (CONS + (|coerceToNativeType| + |a| |x|) + |bfVar#13|)))) + (SETQ |bfVar#11| + (CDR |bfVar#11|)) + (SETQ |bfVar#12| + (CDR |bfVar#12|))))))))) ((|%hasFeature| :CLISP) (PROGN (SETQ |foreignDecl| @@ -497,40 +539,69 @@ |n| (LIST :NAME (SYMBOL-NAME |op'|)) (CONS :ARGUMENTS (LET - ((|bfVar#13| NIL) (|bfVar#11| |s|) - (|x| NIL) (|bfVar#12| |args|) + ((|bfVar#16| NIL) (|bfVar#14| |s|) + (|x| NIL) (|bfVar#15| |args|) (|a| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#11|) + ((OR (ATOM |bfVar#14|) (PROGN (SETQ |x| - (CAR |bfVar#11|)) + (CAR |bfVar#14|)) NIL) - (ATOM |bfVar#12|) + (ATOM |bfVar#15|) (PROGN (SETQ |a| - (CAR |bfVar#12|)) + (CAR |bfVar#15|)) NIL)) (RETURN - (NREVERSE |bfVar#13|))) + (NREVERSE |bfVar#16|))) (#2# - (SETQ |bfVar#13| + (SETQ |bfVar#16| (CONS (LIST |a| (|bfColonColon| 'FFI (|nativeType| |x|))) - |bfVar#13|)))) - (SETQ |bfVar#11| - (CDR |bfVar#11|)) - (SETQ |bfVar#12| - (CDR |bfVar#12|))))) + |bfVar#16|)))) + (SETQ |bfVar#14| + (CDR |bfVar#14|)) + (SETQ |bfVar#15| + (CDR |bfVar#15|))))) (LIST :RETURN-TYPE (|bfColonColon| 'FFI (|nativeType| |t|))) (LIST :LANGUAGE :STDC)))) (SETQ |forwardingFun| - (LIST 'DEFUN |op| |args| (CONS |n| |args|))) + (LIST 'DEFUN |op| |args| + (CONS |n| + (LET + ((|bfVar#19| NIL) + (|bfVar#17| |args|) (|a| NIL) + (|bfVar#18| |s|) (|x| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#17|) + (PROGN + (SETQ |a| + (CAR |bfVar#17|)) + NIL) + (ATOM |bfVar#18|) + (PROGN + (SETQ |x| + (CAR |bfVar#18|)) + NIL)) + (RETURN + (NREVERSE |bfVar#19|))) + (#2# + (SETQ |bfVar#19| + (CONS + (|coerceToNativeType| + |a| |x|) + |bfVar#19|)))) + (SETQ |bfVar#17| + (CDR |bfVar#17|)) + (SETQ |bfVar#18| + (CDR |bfVar#18|))))))) (LIST |foreignDecl| |forwardingFun|))) (#1# (|fatalError| @@ -557,6 +628,7 @@ (SETQ |found| (CATCH 'TRAPPOINT (|bpOutItem|))) (COND ((EQ |found| 'TRAPPED) NIL) + ((EQ |found| '|%%ContinueParsing|) NIL) ((NOT (|bStreamNull| |$inputStream|)) (PROGN (|bpGeneralErrorHere|) NIL)) ((NULL |$stack|) (PROGN (|bpGeneralErrorHere|) NIL)) @@ -596,24 +668,24 @@ (SETQ |expr'| (CDR (CDR (|shoeCompTran| (LIST 'LAMBDA (LIST '|x|) |expr|))))) - (LET ((|bfVar#14| |expr'|) (|t| NIL)) + (LET ((|bfVar#20| |expr'|) (|t| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#14|) - (PROGN (SETQ |t| (CAR |bfVar#14|)) NIL)) + ((OR (ATOM |bfVar#20|) + (PROGN (SETQ |t| (CAR |bfVar#20|)) NIL)) (RETURN NIL)) ('T (COND ((AND (CONSP |t|) (EQ (CAR |t|) 'DECLARE)) (IDENTITY (RPLACA |t| 'DECLAIM)))))) - (SETQ |bfVar#14| (CDR |bfVar#14|)))) + (SETQ |bfVar#20| (CDR |bfVar#20|)))) (|shoeEVALANDFILEACTQ| (COND ((< 1 (LENGTH |expr'|)) (CONS 'PROGN |expr'|)) ('T (CAR |expr'|)))))))) (DEFUN |bpOutItem| () - (PROG (|bfVar#16| |bfVar#15| |r| |ISTMP#2| |l| |ISTMP#1| |b|) + (PROG (|bfVar#22| |bfVar#21| |r| |ISTMP#2| |l| |ISTMP#1| |b|) (DECLARE (SPECIAL |$op|)) (RETURN (PROGN @@ -637,33 +709,33 @@ (|bpPush| (LIST (LIST 'DEFPARAMETER |l| |r|)))) ('T (PROGN - (SETQ |bfVar#15| |b|) - (SETQ |bfVar#16| (CDR |bfVar#15|)) - (CASE (CAR |bfVar#15|) + (SETQ |bfVar#21| |b|) + (SETQ |bfVar#22| (CDR |bfVar#21|)) + (CASE (CAR |bfVar#21|) (|Signature| - (LET ((|op| (CAR |bfVar#16|)) - (|t| (CADR |bfVar#16|))) + (LET ((|op| (CAR |bfVar#22|)) + (|t| (CADR |bfVar#22|))) (|bpPush| (LIST (|genDeclaration| |op| |t|))))) (|%Module| - (LET ((|m| (CAR |bfVar#16|))) + (LET ((|m| (CAR |bfVar#22|))) (|bpPush| (LIST (|shoeCompileTimeEvaluation| (LIST 'PROVIDE (STRING |m|))))))) (|Import| - (LET ((|m| (CAR |bfVar#16|))) + (LET ((|m| (CAR |bfVar#22|))) (|bpPush| (LIST (LIST 'IMPORT-MODULE (STRING |m|)))))) (|ImportSignature| - (LET ((|x| (CAR |bfVar#16|)) - (|sig| (CADR |bfVar#16|))) + (LET ((|x| (CAR |bfVar#22|)) + (|sig| (CADR |bfVar#22|))) (|bpPush| (|genImportDeclaration| |x| |sig|)))) (|TypeAlias| - (LET ((|lhs| (CAR |bfVar#16|)) - (|rhs| (CADR |bfVar#16|))) + (LET ((|lhs| (CAR |bfVar#22|)) + (|rhs| (CADR |bfVar#22|))) (|bpPush| (LIST (|genTypeAlias| |lhs| |rhs|))))) (|ConstantDefinition| - (LET ((|n| (CAR |bfVar#16|)) - (|e| (CADR |bfVar#16|))) + (LET ((|n| (CAR |bfVar#22|)) + (|e| (CADR |bfVar#22|))) (|bpPush| (LIST (LIST 'DEFCONSTANT |n| |e|))))) (T (|bpPush| (LIST (|translateToplevelExpression| |b|)))))))))))) @@ -724,17 +796,17 @@ (PROGN (|shoeFileLine| "DEFINED and not USED" |stream|) (SETQ |a| - (LET ((|bfVar#18| NIL) - (|bfVar#17| (HKEYS |$bootDefined|)) (|i| NIL)) + (LET ((|bfVar#24| NIL) + (|bfVar#23| (HKEYS |$bootDefined|)) (|i| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#17|) - (PROGN (SETQ |i| (CAR |bfVar#17|)) NIL)) - (RETURN (NREVERSE |bfVar#18|))) + ((OR (ATOM |bfVar#23|) + (PROGN (SETQ |i| (CAR |bfVar#23|)) NIL)) + (RETURN (NREVERSE |bfVar#24|))) (#0='T (AND (NOT (GETHASH |i| |$bootUsed|)) - (SETQ |bfVar#18| (CONS |i| |bfVar#18|))))) - (SETQ |bfVar#17| (CDR |bfVar#17|))))) + (SETQ |bfVar#24| (CONS |i| |bfVar#24|))))) + (SETQ |bfVar#23| (CDR |bfVar#23|))))) (|bootOut| (SSORT |a|) |stream|) (|shoeFileLine| " " |stream|) (|shoeFileLine| "DEFINED TWICE" |stream|) @@ -742,29 +814,29 @@ (|shoeFileLine| " " |stream|) (|shoeFileLine| "USED and not DEFINED" |stream|) (SETQ |a| - (LET ((|bfVar#20| NIL) (|bfVar#19| (HKEYS |$bootUsed|)) + (LET ((|bfVar#26| NIL) (|bfVar#25| (HKEYS |$bootUsed|)) (|i| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#19|) - (PROGN (SETQ |i| (CAR |bfVar#19|)) NIL)) - (RETURN (NREVERSE |bfVar#20|))) + ((OR (ATOM |bfVar#25|) + (PROGN (SETQ |i| (CAR |bfVar#25|)) NIL)) + (RETURN (NREVERSE |bfVar#26|))) (#0# (AND (NOT (GETHASH |i| |$bootDefined|)) - (SETQ |bfVar#20| (CONS |i| |bfVar#20|))))) - (SETQ |bfVar#19| (CDR |bfVar#19|))))) - (LET ((|bfVar#21| (SSORT |a|)) (|i| NIL)) + (SETQ |bfVar#26| (CONS |i| |bfVar#26|))))) + (SETQ |bfVar#25| (CDR |bfVar#25|))))) + (LET ((|bfVar#27| (SSORT |a|)) (|i| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#21|) - (PROGN (SETQ |i| (CAR |bfVar#21|)) NIL)) + ((OR (ATOM |bfVar#27|) + (PROGN (SETQ |i| (CAR |bfVar#27|)) NIL)) (RETURN NIL)) (#0# (PROGN (SETQ |b| (CONCAT (PNAME |i|) " is used in ")) (|bootOutLines| (SSORT (GETHASH |i| |$bootUsed|)) |stream| |b|)))) - (SETQ |bfVar#21| (CDR |bfVar#21|)))))))) + (SETQ |bfVar#27| (CDR |bfVar#27|)))))))) (DEFUN |shoeDefUse| (|s|) (LOOP @@ -860,16 +932,16 @@ (#1# (CONS |nee| |$bootDefinedTwice|))))) ('T (HPUT |$bootDefined| |nee| T))) (|defuse1| |e| |niens|) - (LET ((|bfVar#22| |$used|) (|i| NIL)) + (LET ((|bfVar#28| |$used|) (|i| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#22|) - (PROGN (SETQ |i| (CAR |bfVar#22|)) NIL)) + ((OR (ATOM |bfVar#28|) + (PROGN (SETQ |i| (CAR |bfVar#28|)) NIL)) (RETURN NIL)) ('T (HPUT |$bootUsed| |i| (CONS |nee| (GETHASH |i| |$bootUsed|))))) - (SETQ |bfVar#22| (CDR |bfVar#22|)))))))) + (SETQ |bfVar#28| (CDR |bfVar#28|)))))))) (DEFUN |defuse1| (|e| |y|) (PROG (|ndol| |dol| |LETTMP#1| |b| |a| |ISTMP#1|) @@ -907,14 +979,14 @@ (SETQ |LETTMP#1| (|defSeparate| |a|)) (SETQ |dol| (CAR |LETTMP#1|)) (SETQ |ndol| (CADR |LETTMP#1|)) - (LET ((|bfVar#23| |dol|) (|i| NIL)) + (LET ((|bfVar#29| |dol|) (|i| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#23|) - (PROGN (SETQ |i| (CAR |bfVar#23|)) NIL)) + ((OR (ATOM |bfVar#29|) + (PROGN (SETQ |i| (CAR |bfVar#29|)) NIL)) (RETURN NIL)) (#2='T (HPUT |$bootDefined| |i| T))) - (SETQ |bfVar#23| (CDR |bfVar#23|)))) + (SETQ |bfVar#29| (CDR |bfVar#29|)))) (|defuse1| (APPEND |ndol| |e|) |b|))) ((AND (CONSP |y|) (EQ (CAR |y|) 'QUOTE) (PROGN (SETQ |a| (CDR |y|)) #1#)) @@ -923,14 +995,14 @@ (PROGN (SETQ |a| (CDR |y|)) #1#)) NIL) (#0# - (LET ((|bfVar#24| |y|) (|i| NIL)) + (LET ((|bfVar#30| |y|) (|i| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#24|) - (PROGN (SETQ |i| (CAR |bfVar#24|)) NIL)) + ((OR (ATOM |bfVar#30|) + (PROGN (SETQ |i| (CAR |bfVar#30|)) NIL)) (RETURN NIL)) (#2# (|defuse1| |e| |i|))) - (SETQ |bfVar#24| (CDR |bfVar#24|))))))))) + (SETQ |bfVar#30| (CDR |bfVar#30|))))))))) (DEFUN |defSeparate| (|x|) (PROG (|x2| |x1| |LETTMP#1| |f|) @@ -966,13 +1038,13 @@ (GETHASH |x| |$lispWordTable|)) (DEFUN |bootOut| (|l| |outfn|) - (LET ((|bfVar#25| |l|) (|i| NIL)) + (LET ((|bfVar#31| |l|) (|i| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#25|) (PROGN (SETQ |i| (CAR |bfVar#25|)) NIL)) + ((OR (ATOM |bfVar#31|) (PROGN (SETQ |i| (CAR |bfVar#31|)) NIL)) (RETURN NIL)) ('T (|shoeFileLine| (CONCAT " " (PNAME |i|)) |outfn|))) - (SETQ |bfVar#25| (CDR |bfVar#25|))))) + (SETQ |bfVar#31| (CDR |bfVar#31|))))) (DEFUN CLESSP (|s1| |s2|) (NOT (SHOEGREATERP |s1| |s2|))) @@ -1023,18 +1095,18 @@ (PROGN (|shoeFileLine| "USED and where DEFINED" |stream|) (SETQ |c| (SSORT (HKEYS |$bootUsed|))) - (LET ((|bfVar#26| |c|) (|i| NIL)) + (LET ((|bfVar#32| |c|) (|i| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#26|) - (PROGN (SETQ |i| (CAR |bfVar#26|)) NIL)) + ((OR (ATOM |bfVar#32|) + (PROGN (SETQ |i| (CAR |bfVar#32|)) NIL)) (RETURN NIL)) ('T (PROGN (SETQ |a| (CONCAT (PNAME |i|) " is used in ")) (|bootOutLines| (SSORT (GETHASH |i| |$bootUsed|)) |stream| |a|)))) - (SETQ |bfVar#26| (CDR |bfVar#26|)))))))) + (SETQ |bfVar#32| (CDR |bfVar#32|)))))))) (DEFUN FBO (|name| |fn|) (|shoeGeneralFC| #'BO |name| |fn|)) @@ -1075,16 +1147,16 @@ (SETQ |filename| (CONCAT "/tmp/" |filename| ".boot")) (|shoeOpenOutputFile| |stream| |filename| - (LET ((|bfVar#27| |lines|) (|line| NIL)) + (LET ((|bfVar#33| |lines|) (|line| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#27|) + ((OR (ATOM |bfVar#33|) (PROGN - (SETQ |line| (CAR |bfVar#27|)) + (SETQ |line| (CAR |bfVar#33|)) NIL)) (RETURN NIL)) ('T (|shoeFileLine| |line| |stream|))) - (SETQ |bfVar#27| (CDR |bfVar#27|))))) + (SETQ |bfVar#33| (CDR |bfVar#33|))))) T)) ('T NIL)))))) @@ -1099,20 +1171,20 @@ (RETURN (PROGN (SETQ |dq| (CAR |str|)) - (CONS (LIST (LET ((|bfVar#29| NIL) - (|bfVar#28| (|shoeDQlines| |dq|)) + (CONS (LIST (LET ((|bfVar#35| NIL) + (|bfVar#34| (|shoeDQlines| |dq|)) (|line| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#28|) + ((OR (ATOM |bfVar#34|) (PROGN - (SETQ |line| (CAR |bfVar#28|)) + (SETQ |line| (CAR |bfVar#34|)) NIL)) - (RETURN (NREVERSE |bfVar#29|))) + (RETURN (NREVERSE |bfVar#35|))) ('T - (SETQ |bfVar#29| - (CONS (CAR |line|) |bfVar#29|)))) - (SETQ |bfVar#28| (CDR |bfVar#28|))))) + (SETQ |bfVar#35| + (CONS (CAR |line|) |bfVar#35|)))) + (SETQ |bfVar#34| (CDR |bfVar#34|))))) (CDR |str|)))))) (DEFUN |stripm| (|x| |pk| |bt|) @@ -1245,7 +1317,18 @@ |result|)))) (DEFUN |defaultBootToLispFile| (|file|) - (CONCAT (|shoeRemovebootIfNec| |file|) ".clisp")) + (CONCAT (|pathBasename| |file|) ".clisp")) + +(DEFUN |getIntermediateLispFile| (|file| |options|) + (PROG (|out|) + (DECLARE (SPECIAL |$faslType|)) + (RETURN + (PROGN + (SETQ |out| (NAMESTRING (|getOutputPathname| |options|))) + (COND + (|out| (CONCAT (|shoeRemoveStringIfNec| |$faslType| |out|) + ".clisp")) + ('T (|defaultBootToLispFile| |file|))))))) (DEFUN |translateBootFile| (|progname| |options| |file|) (PROG (|outFile|) @@ -1261,7 +1344,8 @@ (RETURN (PROGN (SETQ |intFile| - (BOOTTOCL |file| (|defaultBootToLispFile| |file|))) + (BOOTTOCL |file| + (|getIntermediateLispFile| |file| |options|))) (COND (|intFile| (PROGN diff --git a/src/boot/translator.boot b/src/boot/translator.boot index 1f906a2f..1ddbb2b8 100644 --- a/src/boot/translator.boot +++ b/src/boot/translator.boot @@ -42,6 +42,25 @@ import ast )package "BOOTTRAN" +++ If non nil, holds the name of the current module being translated. +$currentModuleName := nil + +++ Stack of foreign definitions to cope with CLisp's odd FFI interface. +$foreignsDefsForCLisp := [] + +genModuleFinalization(stream) == + %hasFeature KEYWORD::CLISP => + null $foreignsDefsForCLisp => nil + $currentModuleName = nil => + coreError '"current module has no name" + init := + ["DEFUN", INTERN strconc($currentModuleName,"InitCLispFFI"), nil, + ["MAPC",["FUNCTION", "FMAKUNBOUND"], + ["QUOTE",[second d for d in $foreignsDefsForCLisp]]], + :[["EVAL",["QUOTE",d]] for d in $foreignsDefsForCLisp]] + REALLYPRETTYPRINT(init,stream) + nil + +++ True if we are translating code written in Old Boot. $translatingOldBoot := false @@ -88,9 +107,10 @@ BOOTTOCLLINES(lines, fn, outfn)== shoeClLines(a,fn,lines,outfn)== a=nil => shoeNotFound fn $GenVarCounter := 0 - shoeOpenOutputFile(stream,outfn, - (for line in lines repeat shoeFileLine (line,stream); - shoeFileTrees(shoeTransformStream a,stream))) + shoeOpenOutputFile(stream,outfn,_ + ((for line in lines repeat shoeFileLine(line,stream); + shoeFileTrees(shoeTransformStream a,stream)); + genModuleFinalization(stream))) outfn ++ (boottoclc "filename") translates the file "filename.boot" to @@ -115,7 +135,8 @@ shoeClCLines(a,fn,lines,outfn)== shoeOpenOutputFile(stream,outfn, (for line in lines repeat shoeFileLine (line,stream); shoeFileTrees(shoeTransformToFile(stream, - shoeInclude bAddLineNumber(bRgen a,bIgen 0)),stream))) + shoeInclude bAddLineNumber(bRgen a,bIgen 0)),stream); + genModuleFinalization(stream))) outfn ++ (boottomc "filename") translates the file "filename.boot" @@ -389,9 +410,10 @@ genImportDeclaration(op, sig) == [KEYWORD::RETURN_-TYPE,bfColonColon("FFI",nativeType t)], [KEYWORD::LANGUAGE,KEYWORD::STDC]] forwardingFun := - ["DEFUN",op,args, - [n,:[coerceToNativeType(a,t) for a in args for x in s]] - [foreignDecl,forwardingFun] + ["DEFUN",op,args, + [n,:[coerceToNativeType(a,t) for a in args for x in s]]] + $foreignsDefsForCLisp := [foreignDecl,:$foreignsDefsForCLisp] + [forwardingFun] fatalError '"import declaration not implemented for this Lisp" shoeOutParse stream == @@ -451,7 +473,9 @@ bpOutItem()== Signature(op,t) => bpPush [genDeclaration(op,t)] - %Module(m) => + %Module(m) => + $currentModuleName := m + $foreignsDefsForCLisp := nil bpPush [shoeCompileTimeEvaluation ["PROVIDE", STRING m]] Import(m) => @@ -798,10 +822,6 @@ loadNativeModule m == EVAL [bfColonColon("FFI","DEFAULT-FOREIGN-LIBRARY"), m] systemError '"don't know how to load a dynamically linked module" -$OpenAxiomCoreModuleLoaded := false - loadSystemRuntimeCore() == - $OpenAxiomCoreModuleLoaded => nil loadNativeModule strconc(systemLibraryDirectory(), '"libopen-axiom-core",$NativeModuleExt) - $OpenAxiomCoreModuleLoaded := true diff --git a/src/interp/sys-driver.boot b/src/interp/sys-driver.boot index 94c982c4..6d8dbe9a 100644 --- a/src/interp/sys-driver.boot +++ b/src/interp/sys-driver.boot @@ -65,6 +65,10 @@ AxiomCore::%sysInit() == initMemoryConfig() if not (%hasFeature KEYWORD::GCL) then loadSystemRuntimeCore() +)if %hasFeature KEYWORD::CLISP + -- a goat for CLisp FFI, please. + sys_-osInitCLispFFI() +)endif )if %hasFeature KEYWORD::GCL SETQ(COMPILER::_*COMPILE_-VERBOSE_*,false) SETQ(COMPILER::_*SUPPRESS_-COMPILER_-WARNINGS_*,true) diff --git a/src/interp/sys-os.boot b/src/interp/sys-os.boot index 61ace016..1b60ac6d 100644 --- a/src/interp/sys-os.boot +++ b/src/interp/sys-os.boot @@ -38,6 +38,7 @@ -- supporting C runtime libopen-axiom-core. -- +module sys_-os import types import cfuns import sockio @@ -78,7 +79,6 @@ import sockSendInt for import sockGetString for sock__get__string: int -> string -)endif import doSendString for sock__send__string__len: (int, string, int) -> int diff --git a/src/interp/util.lisp b/src/interp/util.lisp index 0dde67ad..3609b591 100644 --- a/src/interp/util.lisp +++ b/src/interp/util.lisp @@ -529,6 +529,7 @@ (reroot) (mapcar #'|AxiomCore|::|importModule| load-files) (|resetWorkspaceVariables|) + (|AxiomCore|::|%sysInit|) (|initHist|) (|initNewWorld|) (compressopen) |