diff options
-rwxr-xr-x | configure | 18 | ||||
-rw-r--r-- | configure.ac | 2 | ||||
-rw-r--r-- | configure.ac.pamphlet | 2 | ||||
-rw-r--r-- | src/ChangeLog | 23 | ||||
-rw-r--r-- | src/boot/ast.boot | 20 | ||||
-rw-r--r-- | src/boot/initial-env.lisp | 5 | ||||
-rw-r--r-- | src/interp/boot-pkg.lisp | 5 | ||||
-rw-r--r-- | src/interp/compiler.boot | 132 | ||||
-rw-r--r-- | src/interp/define.boot | 5 | ||||
-rw-r--r-- | src/interp/fnewmeta.lisp | 28 | ||||
-rw-r--r-- | src/interp/functor.boot | 10 | ||||
-rw-r--r-- | src/interp/sys-constants.boot | 5 | ||||
-rw-r--r-- | src/interp/vmlisp.lisp | 6 | ||||
-rw-r--r-- | src/lisp/core.lisp.in | 3 |
14 files changed, 214 insertions, 50 deletions
@@ -1,6 +1,6 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.60 for OpenAxiom 1.3.0-2009-03-02. +# Generated by GNU Autoconf 2.60 for OpenAxiom 1.3.0-2009-03-08. # # Report bugs to <open-axiom-bugs@lists.sf.net>. # @@ -713,8 +713,8 @@ SHELL=${CONFIG_SHELL-/bin/sh} # Identity of this package. PACKAGE_NAME='OpenAxiom' PACKAGE_TARNAME='openaxiom' -PACKAGE_VERSION='1.3.0-2009-03-02' -PACKAGE_STRING='OpenAxiom 1.3.0-2009-03-02' +PACKAGE_VERSION='1.3.0-2009-03-08' +PACKAGE_STRING='OpenAxiom 1.3.0-2009-03-08' PACKAGE_BUGREPORT='open-axiom-bugs@lists.sf.net' ac_unique_file="src/Makefile.pamphlet" @@ -1406,7 +1406,7 @@ if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF -\`configure' configures OpenAxiom 1.3.0-2009-03-02 to adapt to many kinds of systems. +\`configure' configures OpenAxiom 1.3.0-2009-03-08 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... @@ -1476,7 +1476,7 @@ fi if test -n "$ac_init_help"; then case $ac_init_help in - short | recursive ) echo "Configuration of OpenAxiom 1.3.0-2009-03-02:";; + short | recursive ) echo "Configuration of OpenAxiom 1.3.0-2009-03-08:";; esac cat <<\_ACEOF @@ -1580,7 +1580,7 @@ fi test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF -OpenAxiom configure 1.3.0-2009-03-02 +OpenAxiom configure 1.3.0-2009-03-08 generated by GNU Autoconf 2.60 Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001, @@ -1594,7 +1594,7 @@ cat >config.log <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. -It was created by OpenAxiom $as_me 1.3.0-2009-03-02, which was +It was created by OpenAxiom $as_me 1.3.0-2009-03-08, which was generated by GNU Autoconf 2.60. Invocation command line was $ $0 $@ @@ -26817,7 +26817,7 @@ exec 6>&1 # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" -This file was extended by OpenAxiom $as_me 1.3.0-2009-03-02, which was +This file was extended by OpenAxiom $as_me 1.3.0-2009-03-08, which was generated by GNU Autoconf 2.60. Invocation command line was CONFIG_FILES = $CONFIG_FILES @@ -26866,7 +26866,7 @@ Report bugs to <bug-autoconf@gnu.org>." _ACEOF cat >>$CONFIG_STATUS <<_ACEOF ac_cs_version="\\ -OpenAxiom config.status 1.3.0-2009-03-02 +OpenAxiom config.status 1.3.0-2009-03-08 configured by $0, generated by GNU Autoconf 2.60, with options \\"`echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`\\" diff --git a/configure.ac b/configure.ac index ef263419..97344b46 100644 --- a/configure.ac +++ b/configure.ac @@ -1,6 +1,6 @@ sinclude(config/open-axiom.m4) sinclude(config/aclocal.m4) -AC_INIT([OpenAxiom], [1.3.0-2009-03-02], +AC_INIT([OpenAxiom], [1.3.0-2009-03-08], [open-axiom-bugs@lists.sf.net]) AC_CONFIG_AUX_DIR(config) diff --git a/configure.ac.pamphlet b/configure.ac.pamphlet index 00390bdf..a8785498 100644 --- a/configure.ac.pamphlet +++ b/configure.ac.pamphlet @@ -1140,7 +1140,7 @@ information: <<Autoconf init>>= sinclude(config/open-axiom.m4) sinclude(config/aclocal.m4) -AC_INIT([OpenAxiom], [1.3.0-2009-03-02], +AC_INIT([OpenAxiom], [1.3.0-2009-03-08], [open-axiom-bugs@lists.sf.net]) @ diff --git a/src/ChangeLog b/src/ChangeLog index 06cd80b8..192e1f26 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,26 @@ +2009-03-08 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * interp/fnewmeta.lisp (PARSE-Import): Parse extern entity + signature import. + * interp/functor.boot (encodeLocalFunctionName): New. + * interp/define.boot (compDefine1): Avoid getAbbreviation. + (doIt): Handle %SignatureImport nodes. + * interp/compiler.boot (emitLocalCallInsn): New. + (applyMapping): Use it. + (compApplication): Likewise. + (bootDenotation): New. + (getBasicFFIType): Likewise. + (getFFIDatatype): Likewise. + (getBootType): Likewise. + (checkExternalEntityType): Likewise. + (checkExternalEntity): Likewise. + (removeModifiers): Likewise. + (compSignatureImport): Likewise. + * interp/vmlisp.lisp (|compileLispDefinition|): New. + * interp/boot-pkg.lisp: Import genImportDeclaration. + * boot/initial-env.lisp: Export genImportDeclaration. + * boot/ast.boot: Tidy. Accept `readwrite' modifier. + 2009-03-02 Gabriel Dos Reis <gdr@cs.tamu.edu> * interp/compiler.boot (modeIsAggregateOf): Use RepIfRepHack. diff --git a/src/boot/ast.boot b/src/boot/ast.boot index 270b1221..819f79d4 100644 --- a/src/boot/ast.boot +++ b/src/boot/ast.boot @@ -1249,9 +1249,9 @@ genTypeAlias(head,body) == -- This is used to communicate data between native -- functions and OpenAxiom functions. The `buffer' type -- constructor must be used in conjunction with one of the --- modifier `readonly' or `writeonly', and instantiated --- with one of `char', `byte', `int', `float', and `double'. --- It cannot be used a function return type. +-- modifiers `readonly', `writeonly', or `readwrite', and +-- instantiated with one of `char', `byte', `int', `float', +-- and `double'. It cannot be used as function return type. -- Note that the length of the array is not stored as -- part of the data being transmitted. @@ -1327,7 +1327,7 @@ nativeArgumentType t == coreError '"invalid argument type for a native function" [m,[c,t']] := t -- Require a modifier. - not (m in '(readonly writeonly)) => + not (m in '(readonly writeonly readwrite)) => coreError '"missing modifier for argument type for a native function" -- Only 'pointer' and 'buffer' can be instantiated. not (c in '(buffer pointer)) => @@ -1339,7 +1339,7 @@ nativeArgumentType t == ++ True if objects of type native type `t' are sensible to GC. needsStableReference? t == - not atom t and first t in '(readonly writeonly) + not atom t and first t in '(readonly writeonly readwrite) ++ coerce argument `a' to native type `t', in preparation for ++ a call to a native functions. @@ -1471,9 +1471,9 @@ genCLISPnativeTranslation(op,s,t,op') == [KEYWORD::LANGUAGE,KEYWORD::STDC]] -- The forwarding function. We have to introduce local foreign - -- variables to hold the address of converted Lisp obejcts. Then - -- we have to copy back those that are `writeonly' to simulate - -- the reference semantics. Don't try ever try to pass around + -- variables to hold the address of converted Lisp objects. Then + -- we have to copy back those that are `writeonly' or `readwrite' to + -- simulate the reference semantics. Don't ever try to pass around -- gigantic buffer, you might find out that it is insanely inefficient. forwardingFun := null unstableArgs => ["DEFUN",op,parms, [n,:parms]] @@ -1483,11 +1483,11 @@ genCLISPnativeTranslation(op,s,t,op') == actualArg(p,pairs) == a' := rest ASSOC(p,pairs) => rest rest a' p - -- Fix up the call if there is any `writeonly' parameter. + -- Fix up the call if there is any `write' parameter. call := fixups := [q | not null (q := copyBack p) for p in localPairs] where copyBack [p,x,y,:a] == - x isnt ["writeonly",:.] => nil + x is ["readonly",:.] => nil ["SETF", p, [bfColonColon("FFI","FOREIGN-VALUE"), a]] null fixups => [call] [["PROG1",call, :fixups]] diff --git a/src/boot/initial-env.lisp b/src/boot/initial-env.lisp index 7c98e734..dd67e0c4 100644 --- a/src/boot/initial-env.lisp +++ b/src/boot/initial-env.lisp @@ -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 @@ -49,7 +49,8 @@ (:export "loadNativeModule" "loadSystemRuntimeCore" "$InteractiveMode" - "string2BootTree")) + "string2BootTree" + "genImportDeclaration")) (in-package "BOOTTRAN") diff --git a/src/interp/boot-pkg.lisp b/src/interp/boot-pkg.lisp index da92dd24..a0dbf0fb 100644 --- a/src/interp/boot-pkg.lisp +++ b/src/interp/boot-pkg.lisp @@ -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 @@ -44,7 +44,8 @@ "loadSystemRuntimeCore" "loadFileIfPresent" "$InteractiveMode" - "string2BootTree")) + "string2BootTree" + "genImportDeclaration")) (in-package "BOOT") diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot index b2906c81..399e6a5e 100644 --- a/src/interp/compiler.boot +++ b/src/interp/compiler.boot @@ -202,6 +202,17 @@ compTypeOf(x:=[op,:argl],m,e) == e:= put(op,'modemap,newModemap,e) comp3(x,m,e) +++ We just determined that `op' is called with argument list `args', where +++ `op' is either a local capsule function, or an external function +++ with a local signature-import declaration. Emit insn for the call. +emitLocalCallInsn: (%Symbol,%List,%Env) -> %Code +emitLocalCallInsn(op,args,e) == + op' := -- Find out the linkage name for `op'. + linkName := get(op,"%Link",e) => linkName + encodeLocalFunctionName op + get(op,"%Lang",e) => [op',:args] -- non-Spad calling convention + [op',:args,"$"] + applyMapping([op,:argl],m,e,ml) == #argl^=#ml-1 => nil isCategoryForm(first ml,e) => @@ -220,11 +231,7 @@ applyMapping([op,:argl],m,e,ml) == if argl'="failed" then return nil form:= atom op and not(op in $formalArgList) and null (u := get(op,"value",e)) => - nprefix := $prefix or - -- following needed for referencing local funs at capsule level - getAbbreviation($op,#rest $form) - [op',:argl',"$"] where - op':= INTERN STRCONC(encodeItem nprefix,";",encodeItem op) + emitLocalCallInsn(op,argl',e) -- Compiler synthetized operators are inline. u ^= nil and u.expr is ["XLAM",:.] => ["call",u.expr,:argl'] ['call,['applyFun,op],:argl'] @@ -694,11 +701,7 @@ compApplication(op,argl,m,T) == argTl = "failed" => nil form:= atom T.expr and not (MEMQ(op,$formalArgList) or MEMQ(T.expr,$formalArgList)) => - nprefix := $prefix or - -- following needed for referencing local funs at capsule level - getAbbreviation($op,#rest $form) - [op',:[a.expr for a in argTl],"$"] where - op':= INTERN STRCONC(encodeItem nprefix,";",encodeItem T.expr) + emitLocalCallInsn(T.expr,[a.expr for a in argTl],e) ['call, ['applyFun, T.expr], :[a.expr for a in argTl]] coerce([form, retm, e],resolve(retm,m)) op = 'elt => nil @@ -1253,11 +1256,117 @@ compFromIf(a,m,E) == a="%noBranch" => ["%noBranch",m,E] comp(a,m,E) -compImport: (%Form,%Mode,%Env) -> %Maybe %Triple +compImport: (%Form,%Mode,%Env) -> %Triple compImport(["import",:doms],m,e) == for dom in doms repeat e:=addDomain(dom,e) ["/throwAway",$NoValueMode,e] +--% Foreign Function Interface + +bootDenotation: %Symbol -> %Symbol +bootDenotation s == + INTERN(SYMBOL_-NAME s,"BOOTTRAN") + +++ Return the Boot denotation of a basic FFI type. +getBasicFFIType: %Mode -> %Symbol +getBasicFFIType t == + t = $Byte => bootDenotation "byte" + t = $Int32 => bootDenotation "int32" + t = $Int64 => bootDenotation "int64" + t = $SingleInteger => bootDenotation "int" + t = $SingleFloat => bootDenotation "float" + t = $DoubleFloat => bootDenotation "double" + t = $String => bootDenotation "string" + nil + +++ Return the Boot denotation of an FFI datatype. This is either +++ a basic VM type, or a simple array of sized integer or floating +++ point type. +getFFIDatatype: %Mode -> %Form +getFFIDatatype t == + x := getBasicFFIType t => x + t is [m,["PrimitiveArray",t']] and m in '(ReadOnly WriteOnly) and + member(t',[$Byte,$Int32,$Int64,$SingleFloat,$DoubleFloat]) => + m' := + m = "ReadOnly" => bootDenotation "readonly" + bootDenotation "writeonly" + [m',[bootDenotation "buffer",getBasicFFIType t']] + nil + +++ Return the Boot denotation of a type that is valid in a external entity +++ signature. +getBootType: %Mode -> %Form +getBootType t == + x := getFFIDatatype t => x + t is ["Mapping",ret,:args] => + ret' := + ret = $Void => bootDenotation "void" + getBasicFFIType ret or return nil + args' := [getFFIDatatype arg or return "failed" for arg in args] + args' = "failed" => return nil + [bootDenotation "Mapping",ret',args'] + nil + +++ Verify that mode `t' is admissible in an external entity signature +++ specification, and return its Boot denotation. +checkExternalEntityType(t,e) == + atom t => + stackAndThrow('"Type variable not allowed in import of external entity",nil) + t' := getBootType t => t' + stackAndThrow('"Type %1bp is invalid in a foreign signature",[t]) + + +++ An external entity named `id' is being imported under signature +++ `type' from a foreign language `lang'. Check that the import +++ is valid, and if so return the linkage name of the entity. +checkExternalEntity(id,type,lang,e) == + checkVariableName id + -- An external entity name shall be unique in scope. + getmode(id,e) => + stackAndThrow('"%1b is already in scope",[id]) + -- In particular, an external entity name cannot be overloaded + -- with exported operators. + get(id,"modemap",e) => + stackAndThrow('"%1b already names exported operations in scope",[id]) + -- Only functions are accepted at the moment. And all mentioned + -- types must be those that are supported by the FFI. + type' := checkExternalEntityType(type,e) + type' isnt [=bootDenotation "Mapping",:.] => + stackAndThrow('"Signature for external entity must be a Mapping type",nil) + id' := encodeLocalFunctionName id + [def] := genImportDeclaration(id',[bootDenotation "Signature",id,type']) + compileLispDefinition(id,def) + id' + + +++ Remove possible modifiers in the FFI type expression `t'. +removeModifiers t == + for (ts := [x,:.]) in tails t repeat + x is [m,t'] and m in '(ReadOnly WriteOnly) => + rplac(first ts,t') + t + +++ Compile external entity signature import. +compSignatureImport: (%Form,%Mode,%Env) -> %Maybe %Triple +compSignatureImport(["%SignatureImport",id,type,home],m,e) == + -- 1. Make sure we have the right syntax. + home isnt ["Foreign",:args] => + stackAndThrow('"signature import from be from a %1bp domain",["Foreign"]) + args isnt [lang] => + stackAndThrow('"%1bp takes exactly one argument",["Foreign"]) + not IDENTP lang => + stackAndThrow('"Argument to %1bp must be an identifier",["Foreign"]) + lang ^= "C" => + stackAndThrow('"Sorry: Only %1bp is valid at the moment",["Foreign C"]) + -- 2. Make sure this import is not subverting anything we know + id' := checkExternalEntity(id,type,lang,e) + -- 3. Make a local declaration for it. + T := compMakeDeclaration(id,removeModifiers type,e) or return nil + T.env := put(id,"%Lang",lang,T.env) + T.env:= put(id,"%Link",id',T.env) + convert(T,m) + + --% Compilation of logical operators that may have a pre-defined --% meaning, or may need special handling because or short-circuiting --% etc. @@ -2321,5 +2430,6 @@ for x in [["|", :"compSuchthat"],_ ["rep",:"compRep"],_ ["%Comma",:"compComma"],_ ["%Match",:"compMatch"],_ + ["%SignatureImport",:"compSignatureImport"],_ ["[||]", :"compileQuasiquote"]] repeat MAKEPROP(first x, "SPECIAL", rest x) diff --git a/src/interp/define.boot b/src/interp/define.boot index 6a2aecbb..42414d08 100644 --- a/src/interp/define.boot +++ b/src/interp/define.boot @@ -299,7 +299,7 @@ compDefine1(form,m,e) == null $form => stackAndThrow ['"bad == form ",form] newPrefix:= $prefix => INTERN STRCONC(encodeItem $prefix,'",",encodeItem $op) - getAbbreviation($op,#rest $form) + getConstructorAbbreviationFromDB $op compDefineCapsuleFunction(form,m,e,newPrefix,$formalArgList) compDefineAddSignature([op,:argl],signature,e) == @@ -1492,6 +1492,9 @@ doIt(item,$predl) == item is ["%Inline",type] => processInlineRequest(type,$e) mutateToNothing item + item is ["%SignatureImport",:.] => + [.,.,$e] := compSignatureImport(item,$EmptyMode,$e) + mutateToNothing item item is ["IF",:.] => doItIf(item,$predl,$e) item is ["where",b,:l] => compOrCroak(item,$EmptyMode,$e) item is ["MDEF",:.] => [.,.,$e]:= compOrCroak(item,$EmptyMode,$e) diff --git a/src/interp/fnewmeta.lisp b/src/interp/fnewmeta.lisp index 9867963c..3a0ffa89 100644 --- a/src/interp/fnewmeta.lisp +++ b/src/interp/fnewmeta.lisp @@ -444,15 +444,25 @@ (DEFUN |PARSE-Import| () - (AND (MATCH-ADVANCE-STRING "import") (MUST (|PARSE-Expr| 1000)) - (BANG FIL_TEST - (OPTIONAL - (STAR REPEATOR - (AND (MATCH-ADVANCE-STRING ",") - (MUST (|PARSE-Expr| 1000)))))) - (PUSH-REDUCTION '|PARSE-Import| - (CONS '|import| - (CONS (POP-STACK-2) (APPEND (POP-STACK-1) NIL)))))) + (AND (MATCH-ADVANCE-STRING "import") + (MUST (|PARSE-Expr| 1000)) + (OR (AND (MATCH-ADVANCE-STRING ":") + (MUST (|PARSE-Expression|)) + (MUST (MATCH-ADVANCE-STRING "from")) + (MUST (|PARSE-Expr| 1000)) + (PUSH-REDUCTION '|PARSE-Import| + (CONS '|%SignatureImport| + (CONS (POP-STACK-3) + (CONS (POP-STACK-2) + (CONS (POP-STACK-1) NIL)))))) + (AND (BANG FIL_TEST + (OPTIONAL + (STAR REPEATOR + (AND (MATCH-ADVANCE-STRING ",") + (MUST (|PARSE-Expr| 1000)))))) + (PUSH-REDUCTION '|PARSE-Import| + (CONS '|import| + (CONS (POP-STACK-2) (APPEND (POP-STACK-1) NIL)))))))) ;; domain inlining. Same syntax as import directive; except ;; deliberate restriction on naming one type at a time. diff --git a/src/interp/functor.boot b/src/interp/functor.boot index 5f65c312..b792ff7e 100644 --- a/src/interp/functor.boot +++ b/src/interp/functor.boot @@ -1006,12 +1006,20 @@ encodeFunctionName(fun,package is [packageName,:arglist],signature,sep,count) encodedPair() == n=1 => encodeItem x STRCONC(STRINGIMAGE n,encodeItem x) - encodedName:= INTERNL(getAbbreviation(packageName,#arglist),";", + encodedName:= INTERNL(getConstructorAbbreviationFromDB packageName,";", encodeItem fun,";",encodedSig, sep,STRINGIMAGE count) if $LISPLIB then $lisplibSignatureAlist:= [[encodedName,:signature'],:$lisplibSignatureAlist] encodedName + +++ Return the linkage name of the local operation named `op'. +encodeLocalFunctionName op == + prefix := + $prefix => $prefix + $functorForm => getConstructorAbbreviationFromDB first $functorForm + stackAndThrow('"There is no context for local function %1b",[op]) + INTERN strconc(prefix,'";",encodeItem op) splitEncodedFunctionName(encodedName, sep) == -- [encodedPackage, encodedItem, encodedSig, sequenceNo] or NIL diff --git a/src/interp/sys-constants.boot b/src/interp/sys-constants.boot index 32105963..1277504e 100644 --- a/src/interp/sys-constants.boot +++ b/src/interp/sys-constants.boot @@ -363,6 +363,10 @@ $Syntax == $Boolean == '(Boolean) +$Byte == '(Byte) +$Int32 == '(Int32) +$Int64 == '(Int64) + ++ The SmallInteger domain constructor form $SmallInteger == '(SingleInteger) @@ -414,7 +418,6 @@ $DoubleFloat == $BigFloat == '(Float) - ++ The String constructor domain form $String == '(String) diff --git a/src/interp/vmlisp.lisp b/src/interp/vmlisp.lisp index f3b49f6a..d47b763c 100644 --- a/src/interp/vmlisp.lisp +++ b/src/interp/vmlisp.lisp @@ -637,6 +637,10 @@ #+:CCL (proclaim '(special *vars* *decl*)) ;; declare not handled right +(defun |compileLispDefinition| (name def) + (when *COMP370-APPLY* + (funcall *COMP370-APPLY* name def))) + (defun COMPILE1 (fn) (let* (nargs (fname (car fn)) @@ -664,7 +668,7 @@ (setq body (cond ((eq ltype 'lambda) `(defun ,fname ,nargs . ,body)) ((eq ltype 'mlambda) `(defmacro ,fname ,nargs . ,body)))) - (if *COMP370-APPLY* (funcall *COMP370-APPLY* fname body)) + (|compileLispDefinition| fname body) body)) diff --git a/src/lisp/core.lisp.in b/src/lisp/core.lisp.in index f4f9fa15..de5eea6d 100644 --- a/src/lisp/core.lisp.in +++ b/src/lisp/core.lisp.in @@ -540,7 +540,8 @@ (reduce #'(lambda (x y) (concatenate 'string x y)) msg :initial-value "")) - (t msg)))) + (t msg))) + nil) (defun |warn| (msg) (|diagnosticMessage| "warning" |