diff options
author | dos-reis <gdr@axiomatics.org> | 2009-05-10 18:14:20 +0000 |
---|---|---|
committer | dos-reis <gdr@axiomatics.org> | 2009-05-10 18:14:20 +0000 |
commit | 76905b59dbaaac8fab4892067e973312fd86dde9 (patch) | |
tree | ba38e5ecf6e5ca0f5a9049e3838f7cfc7d7df349 /src/boot | |
parent | fe5fc814694f1a1a04175bc94d15acfe1c259146 (diff) | |
download | open-axiom-76905b59dbaaac8fab4892067e973312fd86dde9.tar.gz |
Update cached Boot translator bootstrap code
Diffstat (limited to 'src/boot')
-rw-r--r-- | src/boot/strap/ast.clisp | 805 | ||||
-rw-r--r-- | src/boot/strap/includer.clisp | 1 | ||||
-rw-r--r-- | src/boot/strap/parser.clisp | 5 | ||||
-rw-r--r-- | src/boot/strap/pile.clisp | 1 | ||||
-rw-r--r-- | src/boot/strap/scanner.clisp | 1 | ||||
-rw-r--r-- | src/boot/strap/tokens.clisp | 6 | ||||
-rw-r--r-- | src/boot/strap/translator.clisp | 547 |
7 files changed, 887 insertions, 479 deletions
diff --git a/src/boot/strap/ast.clisp b/src/boot/strap/ast.clisp index c07edd27..62028541 100644 --- a/src/boot/strap/ast.clisp +++ b/src/boot/strap/ast.clisp @@ -1,3 +1,4 @@ +(PROCLAIM '(OPTIMIZE SPEED)) (IMPORT-MODULE "includer") (IN-PACKAGE "BOOTTRAN") @@ -476,7 +477,7 @@ (SETQ |a| (COND ((EQCAR |op| 'QUOTE) (CADR |op|)) (#0='T |op|))) (SETQ |op| (|bfReName| |a|)) - (SETQ |init| (GET |op| 'SHOETHETA)) + (SETQ |init| (OR (GET |a| 'SHOETHETA) (GET |op| 'SHOETHETA))) (SETQ |g| (|bfGenSymbol|)) (SETQ |g1| (|bfGenSymbol|)) (SETQ |body| (LIST 'SETQ |g| (LIST |op| |g| |g1|))) @@ -507,7 +508,7 @@ (SETQ |a| (COND ((EQCAR |op| 'QUOTE) (CADR |op|)) (#0='T |op|))) (SETQ |op| (|bfReName| |a|)) - (SETQ |init| (GET |op| 'SHOETHETA)) + (SETQ |init| (OR (GET |a| 'SHOETHETA) (GET |op| 'SHOETHETA))) (|bfOpReduce| |op| |init| |body| |itl|)) (#0# (SETQ |a| (|bfTupleConstruct| (ELT |y| 1))) (|bfReduce| |op| |a|)))))) @@ -1259,6 +1260,7 @@ ((OR (|defQuoteId| |l|) (|defQuoteId| |r|)) (LIST 'EQ |l| |r|)) ((NULL |l|) (LIST 'NULL |r|)) ((NULL |r|) (LIST 'NULL |l|)) + ((OR (EQ |l| T) (EQ |r| T)) (LIST 'EQ |l| |r|)) ('T (LIST 'EQUAL |l| |r|)))) (DEFUN |bfLessp| (|l| |r|) @@ -2192,6 +2194,18 @@ (SETQ |args| (CDR |head|)) (LIST 'DEFTYPE |op| |args| (|backquote| |body| |args|)))))) +(DEFCONSTANT |$NativeSimpleDataTypes| + '(|char| |byte| |int| |int8| |uint8| |int16| |uint16| |int32| + |uint32| |int64| |uint64| |float| |float32| |double| + |float64|)) + +(DEFCONSTANT |$NativeSimpleReturnTypes| + (APPEND |$NativeSimpleDataTypes| '(|void| |string|))) + +(DEFUN |isSimpleNativeType| (|t|) + (DECLARE (SPECIAL |$NativeSimpleReturnTypes|)) + (MEMBER |t| |$NativeSimpleReturnTypes|)) + (DECLAIM (FTYPE (FUNCTION (|%Symbol|) |%Symbol|) |coreSymbol|)) (DEFUN |coreSymbol| (|s|) (INTERN (SYMBOL-NAME |s|) '|AxiomCore|)) @@ -2209,26 +2223,779 @@ (RETURN (COND ((NULL |t|) |t|) - ((OR (EQ |t| '|buffer|) (EQ |t| '|pointer|)) + ((ATOM |t|) + (COND + ((SETQ |t'| + (CDR (ASSOC (|coreSymbol| |t|) |$NativeTypeTable|))) + (PROGN + (SETQ |t'| + (COND + ((|%hasFeature| :SBCL) + (|bfColonColon| 'SB-ALIEN |t'|)) + ((|%hasFeature| :CLISP) + (|bfColonColon| 'FFI |t'|)) + (#0='T |t'|))) + (COND + ((AND (EQ |t| '|string|) (|%hasFeature| :SBCL)) + (LIST |t'| :EXTERNAL-FORMAT :ASCII :ELEMENT-TYPE + 'BASE-CHAR)) + (#0# |t'|)))) + ((MEMBER |t| '(|byte| |uint8|)) + (COND + ((|%hasFeature| :SBCL) + (LIST (|bfColonColon| 'SB-ALIEN 'UNSIGNED) 8)) + ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI 'UINT8)) + ((|%hasFeature| :ECL) :UNSIGNED-BYTE) + (#0# (|nativeType| '|char|)))) + ((EQ |t| '|int16|) + (COND + ((|%hasFeature| :SBCL) + (LIST (|bfColonColon| 'SB-ALIEN 'SIGNED) 16)) + ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI 'INT16)) + ((AND (|%hasFeature| :ECL) (|%hasFeature| :UINT16-T)) + :INT16-T) + (#0# (|unknownNativeTypeError| |t|)))) + ((EQ |t| '|uint16|) + (COND + ((|%hasFeature| :SBCL) + (LIST (|bfColonColon| 'SB-ALIEN 'UNSIGNED) 16)) + ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI 'UINT16)) + ((AND (|%hasFeature| :ECL) (|%hasFeature| :UINT16-T)) + :UINT16-T) + (#0# (|unknownNativeTypeError| |t|)))) + ((EQ |t| '|int32|) + (COND + ((|%hasFeature| :SBCL) + (LIST (|bfColonColon| 'SB-ALIEN 'SIGNED) 32)) + ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI 'INT32)) + ((AND (|%hasFeature| :ECL) (|%hasFeature| :UINT32-T)) + :INT32-T) + (#0# (|unknownNativeTypeError| |t|)))) + ((EQ |t| '|uint32|) + (COND + ((|%hasFeature| :SBCL) + (LIST (|bfColonColon| 'SB-ALIEN 'UNSIGNED) 32)) + ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI 'INT32)) + ((AND (|%hasFeature| :ECL) (|%hasFeature| :UINT32-T)) + :UINT32-T) + (#0# (|unknownNativeTypeError| |t|)))) + ((EQ |t| '|int64|) + (COND + ((|%hasFeature| :SBCL) + (LIST (|bfColonColon| 'SB-ALIEN 'SIGNED) 64)) + ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI 'INT64)) + ((AND (|%hasFeature| :ECL) (|%hasFeature| :UINT64-T)) + :INT64-T) + (#0# (|unknownNativeTypeError| |t|)))) + ((EQ |t| '|uint64|) + (COND + ((|%hasFeature| :SBCL) + (LIST (|bfColonColon| 'SB-ALIEN 'UNSIGNED) 64)) + ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI 'UINT64)) + ((AND (|%hasFeature| :ECL) (|%hasFeature| :UINT64-T)) + :UINT64-T) + (#0# (|unknownNativeTypeError| |t|)))) + ((EQ |t| '|float32|) (|nativeType| '|float|)) + ((EQ |t| '|float64|) (|nativeType| '|double|)) + (#0# (|unknownNativeTypeError| |t|)))) + ((EQ (CAR |t|) '|buffer|) (COND - ((|%hasFeature| :GCL) 'FIXNUM) - ((|%hasFeature| :ECL) :POINTER-VOID) - ((|%hasFeature| :SBCL) (LIST '* T)) + ((|%hasFeature| :GCL) 'OBJECT) + ((|%hasFeature| :ECL) :OBJECT) + ((|%hasFeature| :SBCL) (LIST '* (|nativeType| (CADR |t|)))) ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI 'C-POINTER)) - (#0='T (|unknownNativeTypeError| |t|)))) - ((SETQ |t'| - (CDR (ASSOC (|coreSymbol| |t|) |$NativeTypeTable|))) + (#0# (|unknownNativeTypeError| |t|)))) + ((EQ (CAR |t|) '|buffer|) + (COND + ((|%hasFeature| :GCL) '|fixnum|) + ((|%hasFeature| :ECL) :OBJECT) + ((|%hasFeature| :SBCL) (LIST '* (|nativeType| (CADR |t|)))) + ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI 'C-POINTER)) + (#0# (|unknownNativeTypeError| |t|)))) + (#0# (|unknownNativeTypeError| |t|)))))) + +(DEFUN |nativeReturnType| (|t|) + (DECLARE (SPECIAL |$NativeSimpleReturnTypes|)) + (COND + ((MEMBER |t| |$NativeSimpleReturnTypes|) (|nativeType| |t|)) + ('T + (|coreError| + (CONCAT "invalid return type for native function: " + (SYMBOL-NAME |t|)))))) + +(DEFUN |nativeArgumentType| (|t|) + (PROG (|t'| |c| |m|) + (DECLARE (SPECIAL |$NativeSimpleDataTypes|)) + (RETURN + (COND + ((MEMBER |t| |$NativeSimpleDataTypes|) (|nativeType| |t|)) + ((EQ |t| '|string|) (|nativeType| |t|)) + ((OR (ATOM |t|) (NOT (EQL (LENGTH |t|) 2))) + (|coreError| "invalid argument type for a native function")) + (#0='T + (PROGN + (SETQ |m| (CAR |t|)) + (SETQ |c| (CAADR . #1=(|t|))) + (SETQ |t'| (CADADR . #1#)) + (COND + ((NOT (MEMBER |m| '(|readonly| |writeonly| |readwrite|))) + (|coreError| + "missing modifier for argument type for a native function")) + ((NOT (MEMBER |c| '(|buffer| |pointer|))) + (|coreError| + "expect 'buffer' or 'pointer' type instance")) + ((NOT (MEMBER |t'| |$NativeSimpleDataTypes|)) + (|coreError| "expected simple native data type")) + (#0# (|nativeType| (CADR |t|)))))))))) + +(DEFUN |needsStableReference?| (|t|) + (PROG (|m|) + (RETURN + (AND (CONSP |t|) (PROGN (SETQ |m| (CAR |t|)) 'T) + (MEMBER |m| '(|readonly| |writeonly| |readwrite|)))))) + +(DEFUN |coerceToNativeType| (|a| |t|) + (PROG (|y| |c|) + (RETURN + (COND + ((OR (|%hasFeature| :GCL) (|%hasFeature| :ECL) + (|%hasFeature| :CLISP)) + |a|) + ((|%hasFeature| :SBCL) + (COND + ((NOT (|needsStableReference?| |t|)) |a|) + (#0='T + (PROGN + (SETQ |c| (CAADR . #1=(|t|))) + (SETQ |y| (CADADR . #1#)) + (COND + ((EQ |c| '|buffer|) + (LIST (|bfColonColon| 'SB-SYS 'VECTOR-SAP) |a|)) + ((EQ |c| '|pointer|) + (LIST (|bfColonColon| 'SB-SYS 'ALIEN-SAP) |a|)) + ((|needsStableReference?| |t|) + (|fatalError| + (CONCAT "don't know how to coerce argument for native type" + (SYMBOL-NAME |c|))))))))) + (#0# + (|fatalError| + "don't know how to coerce argument for native type")))))) + +(DEFUN |genGCLnativeTranslation| (|op| |s| |t| |op'|) + (PROG (|ccode| |cargs| |cop| |rettype| |argtypes|) + (RETURN + (PROGN + (SETQ |argtypes| + (LET ((|bfVar#133| NIL) (|bfVar#132| |s|) (|x| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#132|) + (PROGN (SETQ |x| (CAR |bfVar#132|)) NIL)) + (RETURN (NREVERSE |bfVar#133|))) + (#0='T + (SETQ |bfVar#133| + (CONS (|nativeArgumentType| |x|) + |bfVar#133|)))) + (SETQ |bfVar#132| (CDR |bfVar#132|))))) + (SETQ |rettype| (|nativeReturnType| |t|)) + (COND + ((LET ((|bfVar#135| T) (|bfVar#134| (CONS |t| |s|)) + (|x| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#134|) + (PROGN (SETQ |x| (CAR |bfVar#134|)) NIL)) + (RETURN |bfVar#135|)) + (#0# + (PROGN + (SETQ |bfVar#135| (|isSimpleNativeType| |x|)) + (COND ((NOT |bfVar#135|) (RETURN NIL)))))) + (SETQ |bfVar#134| (CDR |bfVar#134|)))) + (LIST (LIST 'DEFENTRY |op| |argtypes| + (LIST |rettype| (SYMBOL-NAME |op'|))))) + (#1='T + (PROGN + (SETQ |cop| (CONCAT (SYMBOL-NAME |op'|) "_stub")) + (SETQ |cargs| + (LET ((|bfVar#142| NIL) + (|bfVar#141| (- (LENGTH |s|) 1)) (|i| 0)) + (LOOP + (COND + ((> |i| |bfVar#141|) + (RETURN (NREVERSE |bfVar#142|))) + (#0# + (SETQ |bfVar#142| + (CONS (|genGCLnativeTranslation,mkCArgName| + |i|) + |bfVar#142|)))) + (SETQ |i| (+ |i| 1))))) + (SETQ |ccode| + (LET ((|bfVar#138| "") + (|bfVar#140| + (CONS (|genGCLnativeTranslation,gclTypeInC| + |t|) + (CONS " " + (CONS |cop| + (CONS "(" + (APPEND + (LET + ((|bfVar#136| NIL) (|x| |s|) + (|a| |cargs|)) + (LOOP + (COND + ((OR (ATOM |x|) + (ATOM |a|)) + (RETURN + (NREVERSE |bfVar#136|))) + (#0# + (SETQ |bfVar#136| + (CONS + (|genGCLnativeTranslation,cparm| + |x| |a|) + |bfVar#136|)))) + (SETQ |x| (CDR |x|)) + (SETQ |a| (CDR |a|)))) + (CONS ") { " + (CONS + (COND + ((NOT (EQ |t| '|void|)) + "return ") + (#1# '||)) + (CONS (SYMBOL-NAME |op'|) + (CONS "(" + (APPEND + (LET + ((|bfVar#137| NIL) + (|x| |s|) (|a| |cargs|)) + (LOOP + (COND + ((OR (ATOM |x|) + (ATOM |a|)) + (RETURN + (NREVERSE + |bfVar#137|))) + (#0# + (SETQ |bfVar#137| + (CONS + (|genGCLnativeTranslation,gclArgsInC| + |x| |a|) + |bfVar#137|)))) + (SETQ |x| (CDR |x|)) + (SETQ |a| (CDR |a|)))) + (CONS "); }" NIL)))))))))))) + (|bfVar#139| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#140|) + (PROGN + (SETQ |bfVar#139| (CAR |bfVar#140|)) + NIL)) + (RETURN |bfVar#138|)) + (#0# + (SETQ |bfVar#138| + (CONCAT |bfVar#138| |bfVar#139|)))) + (SETQ |bfVar#140| (CDR |bfVar#140|))))) + (LIST (LIST 'CLINES |ccode|) + (LIST 'DEFENTRY |op| |argtypes| + (LIST |rettype| |cop|)))))))))) + +(DEFUN |genGCLnativeTranslation,mkCArgName| (|i|) + (CONCAT "x" (STRINGIMAGE |i|))) + +(DEFUN |genGCLnativeTranslation,cparm| (|x| |a|) + (CONCAT (|genGCLnativeTranslation,gclTypeInC| (CAR |x|)) " " + (CAR |a|) (COND ((CDR |x|) ", ") ('T "")))) + +(DEFUN |genGCLnativeTranslation,gclTypeInC| (|x|) + (PROG (|ISTMP#3| |ISTMP#2| |ISTMP#1|) + (DECLARE (SPECIAL |$NativeSimpleDataTypes|)) + (RETURN + (COND + ((MEMBER |x| |$NativeSimpleDataTypes|) (SYMBOL-NAME |x|)) + ((EQ |x| '|void|) "void") + ((EQ |x| '|string|) "char*") + ((AND (CONSP |x|) + (PROGN + (SETQ |ISTMP#1| (CDR |x|)) + (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL) + (PROGN + (SETQ |ISTMP#2| (CAR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) + (EQ (CAR |ISTMP#2|) '|pointer|) + (PROGN + (SETQ |ISTMP#3| (CDR |ISTMP#2|)) + (AND (CONSP |ISTMP#3|) + (EQ (CDR |ISTMP#3|) NIL)))))))) + '|fixnum|) + ('T "object"))))) + +(DEFUN |genGCLnativeTranslation,gclArgInC| (|x| |a|) + (PROG (|y| |c|) + (DECLARE (SPECIAL |$NativeSimpleDataTypes|)) + (RETURN + (COND + ((MEMBER |x| |$NativeSimpleDataTypes|) |a|) + ((EQ |x| '|string|) |a|) + (#0='T + (PROGN + (SETQ |c| (CAADR |x|)) + (SETQ |y| (CADADR |x|)) + (COND + ((EQ |c| '|pointer|) |a|) + ((EQ |y| '|char|) (CONCAT |a| "->st.st_self")) + ((EQ |y| '|byte|) (CONCAT |a| "->ust.ust_self")) + ((EQ |y| '|int|) (CONCAT |a| "->fixa.fixa_self")) + ((EQ |y| '|float|) (CONCAT |a| "->sfa.sfa_self")) + ((EQ |y| '|double|) (CONCAT |a| "->lfa.lfa_self")) + (#0# (|coreError| "unknown argument type"))))))))) + +(DEFUN |genGCLnativeTranslation,gclArgsInC| (|x| |a|) + (CONCAT (|genGCLnativeTranslation,gclArgInC| (CAR |x|) (CAR |a|)) + (COND ((CDR |x|) ", ") ('T "")))) + +(DEFUN |genECLnativeTranslation| (|op| |s| |t| |op'|) + (PROG (|rettype| |argtypes| |args|) + (RETURN + (PROGN + (SETQ |args| NIL) + (SETQ |argtypes| NIL) + (LET ((|bfVar#143| |s|) (|x| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#143|) + (PROGN (SETQ |x| (CAR |bfVar#143|)) NIL)) + (RETURN NIL)) + ('T + (PROGN + (SETQ |argtypes| + (CONS (|nativeArgumentType| |x|) |argtypes|)) + (SETQ |args| (CONS (GENSYM) |args|))))) + (SETQ |bfVar#143| (CDR |bfVar#143|)))) + (SETQ |args| (REVERSE |args|)) + (SETQ |rettype| (|nativeReturnType| |t|)) + (LIST (LIST 'DEFUN |op| |args| + (LIST (|bfColonColon| 'FFI 'C-INLINE) |args| + (NREVERSE |argtypes|) |rettype| + (|genECLnativeTranslation,callTemplate| |op'| + (LENGTH |args|) |s|) + :ONE-LINER T))))))) + +(DEFUN |genECLnativeTranslation,callTemplate| (|op| |n| |s|) + (LET ((|bfVar#147| "") + (|bfVar#149| + (CONS (SYMBOL-NAME |op|) + (CONS "(" + (APPEND (LET ((|bfVar#146| NIL) + (|bfVar#144| (- |n| 1)) (|i| 0) + (|bfVar#145| |s|) (|x| NIL)) + (LOOP + (COND + ((OR (> |i| |bfVar#144|) + (ATOM |bfVar#145|) + (PROGN + (SETQ |x| (CAR |bfVar#145|)) + NIL)) + (RETURN (NREVERSE |bfVar#146|))) + (#0='T + (SETQ |bfVar#146| + (CONS + (|genECLnativeTranslation,sharpArg| + |i| |x|) + |bfVar#146|)))) + (SETQ |i| (+ |i| 1)) + (SETQ |bfVar#145| + (CDR |bfVar#145|)))) + (CONS ")" NIL))))) + (|bfVar#148| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#149|) + (PROGN (SETQ |bfVar#148| (CAR |bfVar#149|)) NIL)) + (RETURN |bfVar#147|)) + (#0# (SETQ |bfVar#147| (CONCAT |bfVar#147| |bfVar#148|)))) + (SETQ |bfVar#149| (CDR |bfVar#149|))))) + +(DEFUN |genECLnativeTranslation,sharpArg| (|i| |x|) + (COND + ((EQL |i| 0) + (CONCAT "(#0)" (|genECLnativeTranslation,selectDatum| |x|))) + ('T + (CONCAT "," "(#" (STRINGIMAGE |i|) ")" + (|genECLnativeTranslation,selectDatum| |x|))))) + +(DEFUN |genECLnativeTranslation,selectDatum| (|x|) + (PROG (|y| |c|) + (DECLARE (SPECIAL |$ECLVersionNumber|)) + (RETURN + (COND + ((|isSimpleNativeType| |x|) "") + (#0='T (PROGN - (SETQ |t'| + (SETQ |c| (CAADR |x|)) + (SETQ |y| (CADADR |x|)) + (COND + ((EQ |c| '|buffer|) + (COND + ((OR (EQ |y| '|char|) (EQ |y| '|byte|)) (COND - ((|%hasFeature| :SBCL) - (|bfColonColon| 'SB-ALIEN |t'|)) - ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI |t'|)) - (#0# |t'|))) + ((< |$ECLVersionNumber| 90100) "->vector.self.ch") + ((EQ |y| '|char|) "->vector.self.i8") + (#0# "->vector.self.b8"))) + ((EQ |y| '|int|) "->vector.self.fix") + ((EQ |y| '|float|) "->vector.self.sf") + ((EQ |y| '|double|) "->vector.self.df") + (#0# + (|coreError| + "unknown argument to buffer type constructor")))) + ((EQ |c| '|pointer|) '||) + (#0# (|coreError| "unknown type constructor"))))))))) + +(DEFUN |genCLISPnativeTranslation| (|op| |s| |t| |op'|) + (PROG (|forwardingFun| |ISTMP#2| |p| |fixups| |q| |call| |localPairs| + |y| |x| |ISTMP#1| |a| |foreignDecl| |unstableArgs| |parms| + |n| |argtypes| |rettype|) + (DECLARE (SPECIAL |$foreignsDefsForCLisp|)) + (RETURN + (PROGN + (SETQ |rettype| (|nativeReturnType| |t|)) + (SETQ |argtypes| + (LET ((|bfVar#151| NIL) (|bfVar#150| |s|) (|x| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#150|) + (PROGN (SETQ |x| (CAR |bfVar#150|)) NIL)) + (RETURN (NREVERSE |bfVar#151|))) + (#0='T + (SETQ |bfVar#151| + (CONS (|nativeArgumentType| |x|) + |bfVar#151|)))) + (SETQ |bfVar#150| (CDR |bfVar#150|))))) + (SETQ |n| (INTERN (CONCAT (SYMBOL-NAME |op|) "%clisp-hack"))) + (SETQ |parms| + (LET ((|bfVar#153| NIL) (|bfVar#152| |s|) (|x| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#152|) + (PROGN (SETQ |x| (CAR |bfVar#152|)) NIL)) + (RETURN (NREVERSE |bfVar#153|))) + (#0# + (SETQ |bfVar#153| + (CONS (GENSYM "parm") |bfVar#153|)))) + (SETQ |bfVar#152| (CDR |bfVar#152|))))) + (SETQ |unstableArgs| NIL) + (LET ((|bfVar#154| |parms|) (|p| NIL) (|bfVar#155| |s|) + (|x| NIL) (|bfVar#156| |argtypes|) (|y| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#154|) + (PROGN (SETQ |p| (CAR |bfVar#154|)) NIL) + (ATOM |bfVar#155|) + (PROGN (SETQ |x| (CAR |bfVar#155|)) NIL) + (ATOM |bfVar#156|) + (PROGN (SETQ |y| (CAR |bfVar#156|)) NIL)) + (RETURN NIL)) + (#0# + (COND + ((|needsStableReference?| |x|) + (IDENTITY + (SETQ |unstableArgs| + (CONS (CONS |p| (CONS |x| |y|)) + |unstableArgs|))))))) + (SETQ |bfVar#154| (CDR |bfVar#154|)) + (SETQ |bfVar#155| (CDR |bfVar#155|)) + (SETQ |bfVar#156| (CDR |bfVar#156|)))) + (SETQ |foreignDecl| + (LIST (|bfColonColon| 'FFI 'DEF-CALL-OUT) |n| + (LIST :NAME (SYMBOL-NAME |op'|)) + (CONS :ARGUMENTS + (LET ((|bfVar#159| NIL) + (|bfVar#157| |argtypes|) (|x| NIL) + (|bfVar#158| |parms|) (|a| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#157|) + (PROGN + (SETQ |x| (CAR |bfVar#157|)) + NIL) + (ATOM |bfVar#158|) + (PROGN + (SETQ |a| (CAR |bfVar#158|)) + NIL)) + (RETURN (NREVERSE |bfVar#159|))) + (#0# + (SETQ |bfVar#159| + (CONS (LIST |a| |x|) + |bfVar#159|)))) + (SETQ |bfVar#157| (CDR |bfVar#157|)) + (SETQ |bfVar#158| (CDR |bfVar#158|))))) + (LIST :RETURN-TYPE |rettype|) + (LIST :LANGUAGE :STDC))) + (SETQ |forwardingFun| + (COND + ((NULL |unstableArgs|) + (LIST 'DEFUN |op| |parms| (CONS |n| |parms|))) + (#1='T + (PROGN + (SETQ |localPairs| + (LET ((|bfVar#162| NIL) + (|bfVar#161| |unstableArgs|) + (|bfVar#160| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#161|) + (PROGN + (SETQ |bfVar#160| + (CAR |bfVar#161|)) + NIL)) + (RETURN (NREVERSE |bfVar#162|))) + (#0# + (AND (CONSP |bfVar#160|) + (PROGN + (SETQ |a| (CAR |bfVar#160|)) + (SETQ |ISTMP#1| + (CDR |bfVar#160|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |x| (CAR |ISTMP#1|)) + (SETQ |y| (CDR |ISTMP#1|)) + #2='T))) + (SETQ |bfVar#162| + (CONS + (CONS |a| + (CONS |x| + (CONS |y| (GENSYM "loc")))) + |bfVar#162|))))) + (SETQ |bfVar#161| (CDR |bfVar#161|))))) + (SETQ |call| + (CONS |n| + (LET ((|bfVar#164| NIL) + (|bfVar#163| |parms|) (|p| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#163|) + (PROGN + (SETQ |p| (CAR |bfVar#163|)) + NIL)) + (RETURN (NREVERSE |bfVar#164|))) + (#0# + (SETQ |bfVar#164| + (CONS + (|genCLISPnativeTranslation,actualArg| + |p| |localPairs|) + |bfVar#164|)))) + (SETQ |bfVar#163| (CDR |bfVar#163|)))))) + (SETQ |call| + (PROGN + (SETQ |fixups| + (LET ((|bfVar#166| NIL) + (|bfVar#165| |localPairs|) + (|p| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#165|) + (PROGN + (SETQ |p| (CAR |bfVar#165|)) + NIL)) + (RETURN + (NREVERSE |bfVar#166|))) + (#0# + (AND + (NOT + (NULL + (SETQ |q| + (|genCLISPnativeTranslation,copyBack| + |p|)))) + (SETQ |bfVar#166| + (CONS |q| |bfVar#166|))))) + (SETQ |bfVar#165| + (CDR |bfVar#165|))))) + (COND + ((NULL |fixups|) (LIST |call|)) + (#1# + (LIST (CONS 'PROG1 + (CONS |call| |fixups|))))))) + (LET ((|bfVar#168| |localPairs|) (|bfVar#167| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#168|) + (PROGN + (SETQ |bfVar#167| (CAR |bfVar#168|)) + NIL)) + (RETURN NIL)) + (#0# + (AND (CONSP |bfVar#167|) + (PROGN + (SETQ |p| (CAR |bfVar#167|)) + (SETQ |ISTMP#1| (CDR |bfVar#167|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |x| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| + (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) + (PROGN + (SETQ |y| (CAR |ISTMP#2|)) + (SETQ |a| (CDR |ISTMP#2|)) + #2#))))) + (SETQ |call| + (LIST + (CONS + (|bfColonColon| 'FFI + 'WITH-FOREIGN-OBJECT) + (CONS + (LIST |a| + (LIST 'FUNCALL + (LIST 'INTERN "getCLISPType" + "BOOTTRAN") + |p|) + |p|) + |call|))))))) + (SETQ |bfVar#168| (CDR |bfVar#168|)))) + (CONS 'DEFUN (CONS |op| (CONS |parms| |call|))))))) + (SETQ |$foreignsDefsForCLisp| + (CONS |foreignDecl| |$foreignsDefsForCLisp|)) + (LIST |forwardingFun|))))) + +(DEFUN |genCLISPnativeTranslation,copyBack| (|bfVar#169|) + (PROG (|a| |y| |x| |p|) + (RETURN + (PROGN + (SETQ |p| (CAR |bfVar#169|)) + (SETQ |x| (CADR . #0=(|bfVar#169|))) + (SETQ |y| (CADDR . #0#)) + (SETQ |a| (CDDDR . #0#)) + (COND + ((AND (CONSP |x|) (EQ (CAR |x|) '|readonly|)) NIL) + ('T + (LIST 'SETF |p| + (LIST (|bfColonColon| 'FFI 'FOREIGN-VALUE) |a|)))))))) + +(DEFUN |genCLISPnativeTranslation,actualArg| (|p| |pairs|) + (PROG (|a'|) + (RETURN + (COND + ((SETQ |a'| (CDR (ASSOC |p| |pairs|))) (CDR (CDR |a'|))) + ('T |p|))))) + +(DEFUN |getCLISPType| (|a|) + (LIST (|bfColonColon| 'FFI 'C-ARRAY) (LENGTH |a|))) + +(DEFUN |genSBCLnativeTranslation| (|op| |s| |t| |op'|) + (PROG (|newArgs| |unstableArgs| |args| |argtypes| |rettype|) + (RETURN + (PROGN + (SETQ |rettype| (|nativeReturnType| |t|)) + (SETQ |argtypes| + (LET ((|bfVar#171| NIL) (|bfVar#170| |s|) (|x| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#170|) + (PROGN (SETQ |x| (CAR |bfVar#170|)) NIL)) + (RETURN (NREVERSE |bfVar#171|))) + (#0='T + (SETQ |bfVar#171| + (CONS (|nativeArgumentType| |x|) + |bfVar#171|)))) + (SETQ |bfVar#170| (CDR |bfVar#170|))))) + (SETQ |args| + (LET ((|bfVar#173| NIL) (|bfVar#172| |s|) (|x| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#172|) + (PROGN (SETQ |x| (CAR |bfVar#172|)) NIL)) + (RETURN (NREVERSE |bfVar#173|))) + (#0# + (SETQ |bfVar#173| (CONS (GENSYM) |bfVar#173|)))) + (SETQ |bfVar#172| (CDR |bfVar#172|))))) + (SETQ |unstableArgs| NIL) + (SETQ |newArgs| NIL) + (LET ((|bfVar#174| |args|) (|a| NIL) (|bfVar#175| |s|) + (|x| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#174|) + (PROGN (SETQ |a| (CAR |bfVar#174|)) NIL) + (ATOM |bfVar#175|) + (PROGN (SETQ |x| (CAR |bfVar#175|)) NIL)) + (RETURN NIL)) + (#0# + (PROGN + (SETQ |newArgs| + (CONS (|coerceToNativeType| |a| |x|) |newArgs|)) + (COND + ((|needsStableReference?| |x|) + (SETQ |unstableArgs| (CONS |a| |unstableArgs|))))))) + (SETQ |bfVar#174| (CDR |bfVar#174|)) + (SETQ |bfVar#175| (CDR |bfVar#175|)))) + (COND + ((NULL |unstableArgs|) + (LIST (LIST 'DEFUN |op| |args| + (CONS (INTERN "ALIEN-FUNCALL" "SB-ALIEN") + (CONS (LIST + (INTERN "EXTERN-ALIEN" "SB-ALIEN") + (SYMBOL-NAME |op'|) + (CONS 'FUNCTION + (CONS |rettype| |argtypes|))) + |args|))))) + ('T + (LIST (LIST 'DEFUN |op| |args| + (LIST (|bfColonColon| 'SB-SYS + 'WITH-PINNED-OBJECTS) + (NREVERSE |unstableArgs|) + (CONS (INTERN "ALIEN-FUNCALL" "SB-ALIEN") + (CONS + (LIST + (INTERN "EXTERN-ALIEN" "SB-ALIEN") + (SYMBOL-NAME |op'|) + (CONS 'FUNCTION + (CONS |rettype| |argtypes|))) + (NREVERSE |newArgs|)))))))))))) + +(DEFUN |genImportDeclaration| (|op| |sig|) + (PROG (|s| |t| |m| |ISTMP#2| |op'| |ISTMP#1|) + (RETURN + (COND + ((NOT (AND (CONSP |sig|) (EQ (CAR |sig|) '|Signature|) + (PROGN + (SETQ |ISTMP#1| (CDR |sig|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |op'| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) + (EQ (CDR |ISTMP#2|) NIL) + (PROGN + (SETQ |m| (CAR |ISTMP#2|)) + #0='T))))))) + (|coreError| "invalid signature")) + ((NOT (AND (CONSP |m|) (EQ (CAR |m|) '|Mapping|) + (PROGN + (SETQ |ISTMP#1| (CDR |m|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |t| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) + (EQ (CDR |ISTMP#2|) NIL) + (PROGN + (SETQ |s| (CAR |ISTMP#2|)) + #0#))))))) + (|coreError| "invalid function type")) + (#1='T + (PROGN (COND - ((AND (EQ |t| '|string|) (|%hasFeature| :SBCL)) - (LIST |t'| :EXTERNAL-FORMAT :ASCII :ELEMENT-TYPE - 'BASE-CHAR)) - (#0# |t'|)))) - (#0# (|unknownNativeTypeError| |t|)))))) + ((AND (NOT (NULL |s|)) (SYMBOLP |s|)) + (SETQ |s| (LIST |s|)))) + (COND + ((|%hasFeature| :GCL) + (|genGCLnativeTranslation| |op| |s| |t| |op'|)) + ((|%hasFeature| :SBCL) + (|genSBCLnativeTranslation| |op| |s| |t| |op'|)) + ((|%hasFeature| :CLISP) + (|genCLISPnativeTranslation| |op| |s| |t| |op'|)) + ((|%hasFeature| :ECL) + (|genECLnativeTranslation| |op| |s| |t| |op'|)) + (#1# + (|fatalError| + "import declaration not implemented for this Lisp"))))))))) diff --git a/src/boot/strap/includer.clisp b/src/boot/strap/includer.clisp index 8fb93c82..08964695 100644 --- a/src/boot/strap/includer.clisp +++ b/src/boot/strap/includer.clisp @@ -1,3 +1,4 @@ +(PROCLAIM '(OPTIMIZE SPEED)) (IMPORT-MODULE "tokens") (IN-PACKAGE "BOOTTRAN") diff --git a/src/boot/strap/parser.clisp b/src/boot/strap/parser.clisp index c6270474..fc373262 100644 --- a/src/boot/strap/parser.clisp +++ b/src/boot/strap/parser.clisp @@ -1,3 +1,4 @@ +(PROCLAIM '(OPTIMIZE SPEED)) (IMPORT-MODULE "includer") (IMPORT-MODULE "scanner") @@ -519,8 +520,10 @@ T)) ('T NIL))) +(DEFUN |bpArgtypeList| () (|bpTuple| #'|bpApplication|)) + (DEFUN |bpMapping| () - (OR (AND (|bpParenthesized| #'|bpIdList|) (|bpEqKey| 'ARROW) + (OR (AND (|bpParenthesized| #'|bpArgtypeList|) (|bpEqKey| 'ARROW) (|bpApplication|) (|bpPush| (|Mapping| (|bpPop1|) (|bfUntuple| (|bpPop1|))))) (|bpSimpleMapping|))) diff --git a/src/boot/strap/pile.clisp b/src/boot/strap/pile.clisp index 8a2c8048..4b624e7e 100644 --- a/src/boot/strap/pile.clisp +++ b/src/boot/strap/pile.clisp @@ -1,3 +1,4 @@ +(PROCLAIM '(OPTIMIZE SPEED)) (IMPORT-MODULE "includer") (IMPORT-MODULE "scanner") diff --git a/src/boot/strap/scanner.clisp b/src/boot/strap/scanner.clisp index b6eae196..5590d0ca 100644 --- a/src/boot/strap/scanner.clisp +++ b/src/boot/strap/scanner.clisp @@ -1,3 +1,4 @@ +(PROCLAIM '(OPTIMIZE SPEED)) (IMPORT-MODULE "tokens") (IMPORT-MODULE "includer") diff --git a/src/boot/strap/tokens.clisp b/src/boot/strap/tokens.clisp index c82ec5c5..75e3f3f5 100644 --- a/src/boot/strap/tokens.clisp +++ b/src/boot/strap/tokens.clisp @@ -1,3 +1,4 @@ +(PROCLAIM '(OPTIMIZE SPEED)) (IMPORT-MODULE "initial-env") (IN-PACKAGE "BOOTTRAN") @@ -181,8 +182,9 @@ (LET ((|bfVar#8| (LIST (LIST '+ 0) (LIST '|gcd| 0) (LIST '|lcm| 1) (LIST 'STRCONC "") (LIST '|strconc| "") - (LIST 'MAX (- 999999)) (LIST 'MIN 999999) (LIST '* 1) - (LIST '|times| 1) (LIST 'CONS NIL) (LIST 'APPEND NIL) + (LIST 'CONCAT "") (LIST 'MAX (- 999999)) + (LIST 'MIN 999999) (LIST '* 1) (LIST '|times| 1) + (LIST 'CONS NIL) (LIST 'APPEND NIL) (LIST '|append| NIL) (LIST 'UNION NIL) (LIST 'UNIONQ NIL) (LIST '|union| NIL) (LIST 'NCONC NIL) (LIST '|and| 'T) (LIST '|or| NIL) diff --git a/src/boot/strap/translator.clisp b/src/boot/strap/translator.clisp index 1556ea0a..32cad87a 100644 --- a/src/boot/strap/translator.clisp +++ b/src/boot/strap/translator.clisp @@ -1,3 +1,4 @@ +(PROCLAIM '(OPTIMIZE SPEED)) (IMPORT-MODULE "includer") (IMPORT-MODULE "scanner") @@ -141,7 +142,6 @@ (PROG (|infn|) (RETURN (PROGN - (SETQ *READ-DEFAULT-FLOAT-FORMAT* 'DOUBLE-FLOAT) (SETQ |infn| (|shoeAddbootIfNec| |fn|)) (|shoeOpenInputFile| |a| |infn| (|shoeClLines| |a| |fn| |lines| |outfn|)))))) @@ -504,374 +504,6 @@ (DEFUN |shoeAddComment| (|l|) (CONCAT "; " (CAR |l|))) -(DEFUN |needsStableReference?| (|t|) - (COND - ((|%hasFeature| :GCL) NIL) - ((OR (|%hasFeature| :SBCL) (|%hasFeature| :CLISP) - (|%hasFeature| :ECL)) - (OR (EQ |t| '|pointer|) (EQ |t| '|buffer|))) - ('T T))) - -(DEFUN |coerceToNativeType| (|a| |t|) - (COND - ((|%hasFeature| :GCL) |a|) - ((|%hasFeature| :SBCL) - (COND - ((EQ |t| '|buffer|) - (LIST (|bfColonColon| 'SB-SYS 'VECTOR-SAP) |a|)) - ((EQ |t| '|string|) |a|) - ((|needsStableReference?| |t|) - (|fatalError| - "don't know how to coerce argument for native type")) - (#0='T |a|))) - ((OR (|%hasFeature| :CLISP) (|%hasFeature| :ECL)) - (COND - ((|needsStableReference?| |t|) - (|fatalError| - "don't know how to coerce argument for native type")) - (#0# |a|))) - (#0# - (|fatalError| "don't know how to coerce argument for native type")))) - -(DEFUN |prepareArgumentsForNativeCall| (|args| |types|) - (PROG (|preparedArgs| |unstableArgs|) - (RETURN - (PROGN - (SETQ |unstableArgs| - (LET ((|bfVar#11| NIL) (|bfVar#9| |args|) (|a| NIL) - (|bfVar#10| |types|) (|t| NIL)) - (LOOP - (COND - ((OR (ATOM |bfVar#9|) - (PROGN (SETQ |a| (CAR |bfVar#9|)) NIL) - (ATOM |bfVar#10|) - (PROGN (SETQ |t| (CAR |bfVar#10|)) NIL)) - (RETURN (NREVERSE |bfVar#11|))) - (#0='T - (AND (|needsStableReference?| |t|) - (SETQ |bfVar#11| (CONS |a| |bfVar#11|))))) - (SETQ |bfVar#9| (CDR |bfVar#9|)) - (SETQ |bfVar#10| (CDR |bfVar#10|))))) - (SETQ |preparedArgs| - (LET ((|bfVar#14| NIL) (|bfVar#12| |args|) (|a| NIL) - (|bfVar#13| |types|) (|t| NIL)) - (LOOP - (COND - ((OR (ATOM |bfVar#12|) - (PROGN (SETQ |a| (CAR |bfVar#12|)) NIL) - (ATOM |bfVar#13|) - (PROGN (SETQ |t| (CAR |bfVar#13|)) NIL)) - (RETURN (NREVERSE |bfVar#14|))) - (#0# - (SETQ |bfVar#14| - (CONS (|coerceToNativeType| |a| |t|) - |bfVar#14|)))) - (SETQ |bfVar#12| (CDR |bfVar#12|)) - (SETQ |bfVar#13| (CDR |bfVar#13|))))) - (LIST |unstableArgs| |preparedArgs|))))) - -(DEFUN |genImportDeclaration| (|op| |sig|) - (PROG (|bfVar#33| |forwardingFun| |foreignDecl| |n| |newArgs| - |unstableArgs| |LETTMP#1| |args| |s| |t| |m| |ISTMP#2| - |op'| |ISTMP#1|) - (DECLARE (SPECIAL |$foreignsDefsForCLisp|)) - (RETURN - (COND - ((NOT (AND (CONSP |sig|) (EQ (CAR |sig|) '|Signature|) - (PROGN - (SETQ |ISTMP#1| (CDR |sig|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |op'| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (EQ (CDR |ISTMP#2|) NIL) - (PROGN - (SETQ |m| (CAR |ISTMP#2|)) - #0='T))))))) - (|coreError| "invalid signature")) - ((NOT (AND (CONSP |m|) (EQ (CAR |m|) '|Mapping|) - (PROGN - (SETQ |ISTMP#1| (CDR |m|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |t| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (EQ (CDR |ISTMP#2|) NIL) - (PROGN - (SETQ |s| (CAR |ISTMP#2|)) - #0#))))))) - (|coreError| "invalid function type")) - (#1='T - (PROGN - (COND - ((AND (NOT (NULL |s|)) (SYMBOLP |s|)) - (SETQ |s| (LIST |s|)))) - (COND - ((|needsStableReference?| |t|) - (|fatalError| - "non trivial return type for native function")) - ((|%hasFeature| :GCL) - (LIST (LIST 'DEFENTRY |op| - (LET ((|bfVar#16| NIL) (|bfVar#15| |s|) - (|x| NIL)) - (LOOP - (COND - ((OR (ATOM |bfVar#15|) - (PROGN - (SETQ |x| (CAR |bfVar#15|)) - NIL)) - (RETURN (NREVERSE |bfVar#16|))) - (#2='T - (SETQ |bfVar#16| - (CONS (|nativeType| |x|) - |bfVar#16|)))) - (SETQ |bfVar#15| (CDR |bfVar#15|)))) - (LIST (|nativeType| |t|) (SYMBOL-NAME |op'|))))) - (#1# - (PROGN - (SETQ |args| - (LET ((|bfVar#18| NIL) (|bfVar#17| |s|) - (|x| NIL)) - (LOOP - (COND - ((OR (ATOM |bfVar#17|) - (PROGN - (SETQ |x| (CAR |bfVar#17|)) - NIL)) - (RETURN (NREVERSE |bfVar#18|))) - (#2# - (SETQ |bfVar#18| - (CONS (GENSYM) |bfVar#18|)))) - (SETQ |bfVar#17| (CDR |bfVar#17|))))) - (COND - ((|%hasFeature| :SBCL) - (PROGN - (SETQ |LETTMP#1| - (|prepareArgumentsForNativeCall| |args| |s|)) - (SETQ |unstableArgs| (CAR |LETTMP#1|)) - (SETQ |newArgs| (CADR |LETTMP#1|)) - (COND - ((NULL |unstableArgs|) - (LIST (LIST 'DEFUN |op| |args| - (CONS - (INTERN "ALIEN-FUNCALL" - "SB-ALIEN") - (CONS - (LIST - (INTERN "EXTERN-ALIEN" - "SB-ALIEN") - (SYMBOL-NAME |op'|) - (CONS 'FUNCTION - (CONS (|nativeType| |t|) - (LET - ((|bfVar#20| NIL) - (|bfVar#19| |s|) (|x| NIL)) - (LOOP - (COND - ((OR (ATOM |bfVar#19|) - (PROGN - (SETQ |x| - (CAR |bfVar#19|)) - NIL)) - (RETURN - (NREVERSE |bfVar#20|))) - (#2# - (SETQ |bfVar#20| - (CONS - (|nativeType| |x|) - |bfVar#20|)))) - (SETQ |bfVar#19| - (CDR |bfVar#19|))))))) - |args|))))) - (#1# - (LIST (LIST 'DEFUN |op| |args| - (LIST - (|bfColonColon| 'SB-SYS - 'WITH-PINNED-OBJECTS) - |unstableArgs| - (CONS - (INTERN "ALIEN-FUNCALL" - "SB-ALIEN") - (CONS - (LIST - (INTERN "EXTERN-ALIEN" - "SB-ALIEN") - (SYMBOL-NAME |op'|) - (CONS 'FUNCTION - (CONS (|nativeType| |t|) - (LET - ((|bfVar#22| NIL) - (|bfVar#21| |s|) (|x| NIL)) - (LOOP - (COND - ((OR (ATOM |bfVar#21|) - (PROGN - (SETQ |x| - (CAR |bfVar#21|)) - NIL)) - (RETURN - (NREVERSE - |bfVar#22|))) - (#2# - (SETQ |bfVar#22| - (CONS - (|nativeType| |x|) - |bfVar#22|)))) - (SETQ |bfVar#21| - (CDR |bfVar#21|))))))) - |newArgs|))))))))) - ((|%hasFeature| :CLISP) - (PROGN - (SETQ |foreignDecl| - (PROGN - (SETQ |n| - (INTERN - (CONCAT (SYMBOL-NAME |op|) - "%clisp-hack"))) - (LIST (|bfColonColon| 'FFI 'DEF-CALL-OUT) - |n| (LIST :NAME (SYMBOL-NAME |op'|)) - (CONS :ARGUMENTS - (LET - ((|bfVar#25| NIL) (|bfVar#23| |s|) - (|x| NIL) (|bfVar#24| |args|) - (|a| NIL)) - (LOOP - (COND - ((OR (ATOM |bfVar#23|) - (PROGN - (SETQ |x| - (CAR |bfVar#23|)) - NIL) - (ATOM |bfVar#24|) - (PROGN - (SETQ |a| - (CAR |bfVar#24|)) - NIL)) - (RETURN - (NREVERSE |bfVar#25|))) - (#2# - (SETQ |bfVar#25| - (CONS - (LIST |a| - (|nativeType| |x|)) - |bfVar#25|)))) - (SETQ |bfVar#23| - (CDR |bfVar#23|)) - (SETQ |bfVar#24| - (CDR |bfVar#24|))))) - (LIST :RETURN-TYPE - (|nativeType| |t|)) - (LIST :LANGUAGE :STDC)))) - (SETQ |forwardingFun| - (LIST 'DEFUN |op| |args| - (CONS |n| - (LET - ((|bfVar#28| NIL) - (|bfVar#26| |args|) (|a| NIL) - (|bfVar#27| |s|) (|x| NIL)) - (LOOP - (COND - ((OR (ATOM |bfVar#26|) - (PROGN - (SETQ |a| - (CAR |bfVar#26|)) - NIL) - (ATOM |bfVar#27|) - (PROGN - (SETQ |x| - (CAR |bfVar#27|)) - NIL)) - (RETURN - (NREVERSE |bfVar#28|))) - (#2# - (SETQ |bfVar#28| - (CONS - (|coerceToNativeType| - |a| |t|) - |bfVar#28|)))) - (SETQ |bfVar#26| - (CDR |bfVar#26|)) - (SETQ |bfVar#27| - (CDR |bfVar#27|))))))) - (SETQ |$foreignsDefsForCLisp| - (CONS |foreignDecl| |$foreignsDefsForCLisp|)) - (LIST |forwardingFun|))) - ((|%hasFeature| :ECL) - (LIST (LIST 'DEFUN |op| |args| - (LIST (|bfColonColon| 'FFI 'C-INLINE) - |args| - (LET - ((|bfVar#30| NIL) - (|bfVar#29| |s|) (|x| NIL)) - (LOOP - (COND - ((OR (ATOM |bfVar#29|) - (PROGN - (SETQ |x| - (CAR |bfVar#29|)) - NIL)) - (RETURN - (NREVERSE |bfVar#30|))) - (#2# - (SETQ |bfVar#30| - (CONS (|nativeType| |x|) - |bfVar#30|)))) - (SETQ |bfVar#29| - (CDR |bfVar#29|)))) - (|nativeType| |t|) - (PROGN - (SETQ |bfVar#33| - (|genImportDeclaration,callTemplate| - |op'| (LENGTH |args|))) - (LET - ((|bfVar#31| (CAR |bfVar#33|)) - (|bfVar#34| (CDR |bfVar#33|)) - (|bfVar#32| NIL)) - (LOOP - (COND - ((OR (ATOM |bfVar#34|) - (PROGN - (SETQ |bfVar#32| - (CAR |bfVar#34|)) - NIL)) - (RETURN |bfVar#31|)) - (#2# - (SETQ |bfVar#31| - (CONCAT |bfVar#31| - |bfVar#32|)))) - (SETQ |bfVar#34| - (CDR |bfVar#34|))))) - :ONE-LINER T)))) - (#1# - (|fatalError| - "import declaration not implemented for this Lisp")))))))))))) - -(DEFUN |genImportDeclaration,callTemplate| (|op| |n|) - (CONS (SYMBOL-NAME |op|) - (CONS "(" - (APPEND (LET ((|bfVar#36| NIL) (|bfVar#35| (- |n| 1)) - (|i| 0)) - (LOOP - (COND - ((> |i| |bfVar#35|) - (RETURN (NREVERSE |bfVar#36|))) - ('T - (SETQ |bfVar#36| - (APPEND - (REVERSE - (|genImportDeclaration,sharpArg| - |i|)) - |bfVar#36|)))) - (SETQ |i| (+ |i| 1)))) - (CONS ")" NIL))))) - -(DEFUN |genImportDeclaration,sharpArg| (|i|) - (COND - ((EQL |i| 0) (LIST "#0")) - ('T (LIST "," "#" (STRINGIMAGE |i|))))) - (DEFUN |shoeOutParse| (|stream|) (PROG (|found|) (DECLARE (SPECIAL |$bpParenCount| |$bpCount| |$returns| |$typings| @@ -926,14 +558,14 @@ ('T (LIST 'DECLAIM (LIST 'TYPE |t| |n|))))))) (DEFUN |translateSignatureDeclaration| (|d|) - (PROG (|bfVar#38| |bfVar#37|) + (PROG (|bfVar#10| |bfVar#9|) (RETURN (PROGN - (SETQ |bfVar#37| |d|) - (SETQ |bfVar#38| (CDR |bfVar#37|)) - (CASE (CAR |bfVar#37|) + (SETQ |bfVar#9| |d|) + (SETQ |bfVar#10| (CDR |bfVar#9|)) + (CASE (CAR |bfVar#9|) (|Signature| - (LET ((|n| (CAR |bfVar#38|)) (|t| (CADR |bfVar#38|))) + (LET ((|n| (CAR |bfVar#10|)) (|t| (CADR |bfVar#10|))) (|genDeclaration| |n| |t|))) (T (|coreError| "signature expected"))))))) @@ -945,17 +577,17 @@ (SETQ |expr'| (CDR (CDR (|shoeCompTran| (LIST 'LAMBDA (LIST '|x|) |expr|))))) - (LET ((|bfVar#39| |expr'|) (|t| NIL)) + (LET ((|bfVar#11| |expr'|) (|t| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#39|) - (PROGN (SETQ |t| (CAR |bfVar#39|)) NIL)) + ((OR (ATOM |bfVar#11|) + (PROGN (SETQ |t| (CAR |bfVar#11|)) NIL)) (RETURN NIL)) ('T (COND ((AND (CONSP |t|) (EQ (CAR |t|) 'DECLARE)) (IDENTITY (RPLACA |t| 'DECLAIM)))))) - (SETQ |bfVar#39| (CDR |bfVar#39|)))) + (SETQ |bfVar#11| (CDR |bfVar#11|)))) (SETQ |expr'| (COND ((< 1 (LENGTH |expr'|)) (CONS 'PROGN |expr'|)) @@ -968,7 +600,7 @@ (COND (|export?| |d|) ('T |d|))) (DEFUN |translateToplevel| (|b| |export?|) - (PROG (|lhs| |t| |ISTMP#2| |n| |ISTMP#1| |sig| |bfVar#45| |bfVar#44| + (PROG (|lhs| |t| |ISTMP#2| |n| |ISTMP#1| |sig| |bfVar#17| |bfVar#16| |xs|) (DECLARE (SPECIAL |$InteractiveMode| |$foreignsDefsForCLisp| |$currentModuleName|)) @@ -977,63 +609,63 @@ ((ATOM |b|) (LIST |b|)) ((AND (CONSP |b|) (EQ (CAR |b|) 'TUPLE) (PROGN (SETQ |xs| (CDR |b|)) #0='T)) - (LET ((|bfVar#41| NIL) (|bfVar#40| |xs|) (|x| NIL)) + (LET ((|bfVar#13| NIL) (|bfVar#12| |xs|) (|x| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#40|) - (PROGN (SETQ |x| (CAR |bfVar#40|)) NIL)) - (RETURN (NREVERSE |bfVar#41|))) + ((OR (ATOM |bfVar#12|) + (PROGN (SETQ |x| (CAR |bfVar#12|)) NIL)) + (RETURN (NREVERSE |bfVar#13|))) (#1='T - (SETQ |bfVar#41| + (SETQ |bfVar#13| (CONS (|maybeExportDecl| |x| |export?|) - |bfVar#41|)))) - (SETQ |bfVar#40| (CDR |bfVar#40|))))) + |bfVar#13|)))) + (SETQ |bfVar#12| (CDR |bfVar#12|))))) (#2='T (PROGN - (SETQ |bfVar#44| |b|) - (SETQ |bfVar#45| (CDR |bfVar#44|)) - (CASE (CAR |bfVar#44|) + (SETQ |bfVar#16| |b|) + (SETQ |bfVar#17| (CDR |bfVar#16|)) + (CASE (CAR |bfVar#16|) (|Signature| - (LET ((|op| (CAR |bfVar#45|)) (|t| (CADR |bfVar#45|))) + (LET ((|op| (CAR |bfVar#17|)) (|t| (CADR |bfVar#17|))) (LIST (|maybeExportDecl| (|genDeclaration| |op| |t|) |export?|)))) (|%Module| - (LET ((|m| (CAR |bfVar#45|)) (|ds| (CADR |bfVar#45|))) + (LET ((|m| (CAR |bfVar#17|)) (|ds| (CADR |bfVar#17|))) (PROGN (SETQ |$currentModuleName| |m|) (SETQ |$foreignsDefsForCLisp| NIL) (CONS (LIST 'PROVIDE (STRING |m|)) - (LET ((|bfVar#43| NIL) (|bfVar#42| |ds|) + (LET ((|bfVar#15| NIL) (|bfVar#14| |ds|) (|d| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#42|) + ((OR (ATOM |bfVar#14|) (PROGN - (SETQ |d| (CAR |bfVar#42|)) + (SETQ |d| (CAR |bfVar#14|)) NIL)) - (RETURN (NREVERSE |bfVar#43|))) + (RETURN (NREVERSE |bfVar#15|))) (#1# - (SETQ |bfVar#43| + (SETQ |bfVar#15| (CONS (CAR (|translateToplevel| |d| T)) - |bfVar#43|)))) - (SETQ |bfVar#42| (CDR |bfVar#42|)))))))) + |bfVar#15|)))) + (SETQ |bfVar#14| (CDR |bfVar#14|)))))))) (|Import| - (LET ((|m| (CAR |bfVar#45|))) + (LET ((|m| (CAR |bfVar#17|))) (LIST (LIST 'IMPORT-MODULE (STRING |m|))))) (|ImportSignature| - (LET ((|x| (CAR |bfVar#45|)) - (|sig| (CADR |bfVar#45|))) + (LET ((|x| (CAR |bfVar#17|)) + (|sig| (CADR |bfVar#17|))) (|genImportDeclaration| |x| |sig|))) (|%TypeAlias| - (LET ((|lhs| (CAR |bfVar#45|)) - (|rhs| (CADR |bfVar#45|))) + (LET ((|lhs| (CAR |bfVar#17|)) + (|rhs| (CADR |bfVar#17|))) (LIST (|maybeExportDecl| (|genTypeAlias| |lhs| |rhs|) |export?|)))) (|ConstantDefinition| - (LET ((|lhs| (CAR |bfVar#45|)) - (|rhs| (CADR |bfVar#45|))) + (LET ((|lhs| (CAR |bfVar#17|)) + (|rhs| (CADR |bfVar#17|))) (PROGN (SETQ |sig| NIL) (COND @@ -1058,8 +690,8 @@ (LIST 'DEFCONSTANT |lhs| |rhs|) |export?|))))) (|%Assignment| - (LET ((|lhs| (CAR |bfVar#45|)) - (|rhs| (CADR |bfVar#45|))) + (LET ((|lhs| (CAR |bfVar#17|)) + (|rhs| (CADR |bfVar#17|))) (PROGN (SETQ |sig| NIL) (COND @@ -1088,7 +720,7 @@ (LIST 'DEFPARAMETER |lhs| |rhs|) |export?|))))))) (|namespace| - (LET ((|n| (CAR |bfVar#45|))) + (LET ((|n| (CAR |bfVar#17|))) (LIST (LIST 'IN-PACKAGE (STRING |n|))))) (T (LIST (|translateToplevelExpression| |b|)))))))))) @@ -1186,17 +818,17 @@ (PROGN (|shoeFileLine| "DEFINED and not USED" |stream|) (SETQ |a| - (LET ((|bfVar#47| NIL) - (|bfVar#46| (HKEYS |$bootDefined|)) (|i| NIL)) + (LET ((|bfVar#19| NIL) + (|bfVar#18| (HKEYS |$bootDefined|)) (|i| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#46|) - (PROGN (SETQ |i| (CAR |bfVar#46|)) NIL)) - (RETURN (NREVERSE |bfVar#47|))) + ((OR (ATOM |bfVar#18|) + (PROGN (SETQ |i| (CAR |bfVar#18|)) NIL)) + (RETURN (NREVERSE |bfVar#19|))) (#0='T (AND (NOT (GETHASH |i| |$bootUsed|)) - (SETQ |bfVar#47| (CONS |i| |bfVar#47|))))) - (SETQ |bfVar#46| (CDR |bfVar#46|))))) + (SETQ |bfVar#19| (CONS |i| |bfVar#19|))))) + (SETQ |bfVar#18| (CDR |bfVar#18|))))) (|bootOut| (SSORT |a|) |stream|) (|shoeFileLine| " " |stream|) (|shoeFileLine| "DEFINED TWICE" |stream|) @@ -1204,29 +836,29 @@ (|shoeFileLine| " " |stream|) (|shoeFileLine| "USED and not DEFINED" |stream|) (SETQ |a| - (LET ((|bfVar#49| NIL) (|bfVar#48| (HKEYS |$bootUsed|)) + (LET ((|bfVar#21| NIL) (|bfVar#20| (HKEYS |$bootUsed|)) (|i| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#48|) - (PROGN (SETQ |i| (CAR |bfVar#48|)) NIL)) - (RETURN (NREVERSE |bfVar#49|))) + ((OR (ATOM |bfVar#20|) + (PROGN (SETQ |i| (CAR |bfVar#20|)) NIL)) + (RETURN (NREVERSE |bfVar#21|))) (#0# (AND (NOT (GETHASH |i| |$bootDefined|)) - (SETQ |bfVar#49| (CONS |i| |bfVar#49|))))) - (SETQ |bfVar#48| (CDR |bfVar#48|))))) - (LET ((|bfVar#50| (SSORT |a|)) (|i| NIL)) + (SETQ |bfVar#21| (CONS |i| |bfVar#21|))))) + (SETQ |bfVar#20| (CDR |bfVar#20|))))) + (LET ((|bfVar#22| (SSORT |a|)) (|i| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#50|) - (PROGN (SETQ |i| (CAR |bfVar#50|)) NIL)) + ((OR (ATOM |bfVar#22|) + (PROGN (SETQ |i| (CAR |bfVar#22|)) NIL)) (RETURN NIL)) (#0# (PROGN (SETQ |b| (CONCAT (PNAME |i|) " is used in ")) (|bootOutLines| (SSORT (GETHASH |i| |$bootUsed|)) |stream| |b|)))) - (SETQ |bfVar#50| (CDR |bfVar#50|)))))))) + (SETQ |bfVar#22| (CDR |bfVar#22|)))))))) (DEFUN |shoeDefUse| (|s|) (LOOP @@ -1322,16 +954,16 @@ (#1# (CONS |nee| |$bootDefinedTwice|))))) ('T (HPUT |$bootDefined| |nee| T))) (|defuse1| |e| |niens|) - (LET ((|bfVar#51| |$used|) (|i| NIL)) + (LET ((|bfVar#23| |$used|) (|i| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#51|) - (PROGN (SETQ |i| (CAR |bfVar#51|)) NIL)) + ((OR (ATOM |bfVar#23|) + (PROGN (SETQ |i| (CAR |bfVar#23|)) NIL)) (RETURN NIL)) ('T (HPUT |$bootUsed| |i| (CONS |nee| (GETHASH |i| |$bootUsed|))))) - (SETQ |bfVar#51| (CDR |bfVar#51|)))))))) + (SETQ |bfVar#23| (CDR |bfVar#23|)))))))) (DEFUN |defuse1| (|e| |y|) (PROG (|ndol| |dol| |LETTMP#1| |b| |a| |ISTMP#1|) @@ -1369,14 +1001,14 @@ (SETQ |LETTMP#1| (|defSeparate| |a|)) (SETQ |dol| (CAR |LETTMP#1|)) (SETQ |ndol| (CADR |LETTMP#1|)) - (LET ((|bfVar#52| |dol|) (|i| NIL)) + (LET ((|bfVar#24| |dol|) (|i| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#52|) - (PROGN (SETQ |i| (CAR |bfVar#52|)) NIL)) + ((OR (ATOM |bfVar#24|) + (PROGN (SETQ |i| (CAR |bfVar#24|)) NIL)) (RETURN NIL)) (#2='T (HPUT |$bootDefined| |i| T))) - (SETQ |bfVar#52| (CDR |bfVar#52|)))) + (SETQ |bfVar#24| (CDR |bfVar#24|)))) (|defuse1| (APPEND |ndol| |e|) |b|))) ((AND (CONSP |y|) (EQ (CAR |y|) 'QUOTE) (PROGN (SETQ |a| (CDR |y|)) #1#)) @@ -1385,14 +1017,14 @@ (PROGN (SETQ |a| (CDR |y|)) #1#)) NIL) (#0# - (LET ((|bfVar#53| |y|) (|i| NIL)) + (LET ((|bfVar#25| |y|) (|i| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#53|) - (PROGN (SETQ |i| (CAR |bfVar#53|)) NIL)) + ((OR (ATOM |bfVar#25|) + (PROGN (SETQ |i| (CAR |bfVar#25|)) NIL)) (RETURN NIL)) (#2# (|defuse1| |e| |i|))) - (SETQ |bfVar#53| (CDR |bfVar#53|))))))))) + (SETQ |bfVar#25| (CDR |bfVar#25|))))))))) (DEFUN |defSeparate| (|x|) (PROG (|x2| |x1| |LETTMP#1| |f|) @@ -1428,13 +1060,13 @@ (GETHASH |x| |$lispWordTable|)) (DEFUN |bootOut| (|l| |outfn|) - (LET ((|bfVar#54| |l|) (|i| NIL)) + (LET ((|bfVar#26| |l|) (|i| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#54|) (PROGN (SETQ |i| (CAR |bfVar#54|)) NIL)) + ((OR (ATOM |bfVar#26|) (PROGN (SETQ |i| (CAR |bfVar#26|)) NIL)) (RETURN NIL)) ('T (|shoeFileLine| (CONCAT " " (PNAME |i|)) |outfn|))) - (SETQ |bfVar#54| (CDR |bfVar#54|))))) + (SETQ |bfVar#26| (CDR |bfVar#26|))))) (DEFUN CLESSP (|s1| |s2|) (NOT (SHOEGREATERP |s1| |s2|))) @@ -1485,18 +1117,18 @@ (PROGN (|shoeFileLine| "USED and where DEFINED" |stream|) (SETQ |c| (SSORT (HKEYS |$bootUsed|))) - (LET ((|bfVar#55| |c|) (|i| NIL)) + (LET ((|bfVar#27| |c|) (|i| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#55|) - (PROGN (SETQ |i| (CAR |bfVar#55|)) NIL)) + ((OR (ATOM |bfVar#27|) + (PROGN (SETQ |i| (CAR |bfVar#27|)) NIL)) (RETURN NIL)) ('T (PROGN (SETQ |a| (CONCAT (PNAME |i|) " is used in ")) (|bootOutLines| (SSORT (GETHASH |i| |$bootUsed|)) |stream| |a|)))) - (SETQ |bfVar#55| (CDR |bfVar#55|)))))))) + (SETQ |bfVar#27| (CDR |bfVar#27|)))))))) (DEFUN FBO (|name| |fn|) (|shoeGeneralFC| #'BO |name| |fn|)) @@ -1537,16 +1169,16 @@ (SETQ |filename| (CONCAT "/tmp/" |filename| ".boot")) (|shoeOpenOutputFile| |stream| |filename| - (LET ((|bfVar#56| |lines|) (|line| NIL)) + (LET ((|bfVar#28| |lines|) (|line| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#56|) + ((OR (ATOM |bfVar#28|) (PROGN - (SETQ |line| (CAR |bfVar#56|)) + (SETQ |line| (CAR |bfVar#28|)) NIL)) (RETURN NIL)) ('T (|shoeFileLine| |line| |stream|))) - (SETQ |bfVar#56| (CDR |bfVar#56|))))) + (SETQ |bfVar#28| (CDR |bfVar#28|))))) T)) ('T NIL)))))) @@ -1561,20 +1193,20 @@ (RETURN (PROGN (SETQ |dq| (CAR |str|)) - (CONS (LIST (LET ((|bfVar#58| NIL) - (|bfVar#57| (|shoeDQlines| |dq|)) + (CONS (LIST (LET ((|bfVar#30| NIL) + (|bfVar#29| (|shoeDQlines| |dq|)) (|line| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#57|) + ((OR (ATOM |bfVar#29|) (PROGN - (SETQ |line| (CAR |bfVar#57|)) + (SETQ |line| (CAR |bfVar#29|)) NIL)) - (RETURN (NREVERSE |bfVar#58|))) + (RETURN (NREVERSE |bfVar#30|))) ('T - (SETQ |bfVar#58| - (CONS (CAR |line|) |bfVar#58|)))) - (SETQ |bfVar#57| (CDR |bfVar#57|))))) + (SETQ |bfVar#30| + (CONS (CAR |line|) |bfVar#30|)))) + (SETQ |bfVar#29| (CDR |bfVar#29|))))) (CDR |str|)))))) (DEFUN |stripm| (|x| |pk| |bt|) @@ -1759,7 +1391,8 @@ (DEFUN |loadNativeModule| (|m|) (COND ((|%hasFeature| :SBCL) - (FUNCALL (|bfColonColon| 'SB-ALIEN 'LOAD-SHARED-OBJECT) |m|)) + (FUNCALL (|bfColonColon| 'SB-ALIEN 'LOAD-SHARED-OBJECT) |m| + :DONT-SAVE T)) ((|%hasFeature| :CLISP) (EVAL (LIST (|bfColonColon| 'FFI 'DEFAULT-FOREIGN-LIBRARY) |m|))) ((|%hasFeature| :ECL) |