aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authordos-reis <gdr@axiomatics.org>2010-02-08 01:08:42 +0000
committerdos-reis <gdr@axiomatics.org>2010-02-08 01:08:42 +0000
commit3f8f61e055c818711c6a6136b89b6e9fedda8c3c (patch)
treeb6892bc44f1604fe03e29cdf7a28109a63adb370 /src
parent49820464da35e02649ec0d4107ac3ea4491e1620 (diff)
downloadopen-axiom-3f8f61e055c818711c6a6136b89b6e9fedda8c3c.tar.gz
Add support for CLozure CL.
* lisp/core.lisp.in: Add support for Clozure CL. (main): Remove as unused. * driver/utils.h (openaxiom_runtime): Add openaxiom_clozure_runtime. * boot/translator.boot (loadNativeModule): Handle Clozure CL. * boot/ast.boot (nativeType): Handle Clozure's FFI types. (nativeReturnType): Likewise. (coerceToNativeType): Likewise. (genCLOZUREnativeTranslation): New. (genImportDeclaration): Use it. * interp/vmlisp.lisp (SINTP): Remove duplicate definition. (SMINTP): Likewise. (ZERO?): Likewise. (GCMSG): Reorganize definition. (BPINAME): Likewise.
Diffstat (limited to 'src')
-rw-r--r--src/ChangeLog18
-rw-r--r--src/boot/ast.boot74
-rw-r--r--src/boot/translator.boot4
-rw-r--r--src/driver/utils.h3
-rw-r--r--src/interp/i-syscmd.boot2
-rw-r--r--src/interp/vmlisp.lisp113
-rw-r--r--src/lisp/core.lisp.in47
7 files changed, 154 insertions, 107 deletions
diff --git a/src/ChangeLog b/src/ChangeLog
index 65af692f..0c6ab682 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,5 +1,23 @@
2010-02-07 Gabriel Dos Reis <gdr@cs.tamu.edu>
+ Add support for CLozure CL.
+ * lisp/core.lisp.in: Add support for Clozure CL.
+ (main): Remove as unused.
+ * driver/utils.h (openaxiom_runtime): Add openaxiom_clozure_runtime.
+ * boot/translator.boot (loadNativeModule): Handle Clozure CL.
+ * boot/ast.boot (nativeType): Handle Clozure's FFI types.
+ (nativeReturnType): Likewise.
+ (coerceToNativeType): Likewise.
+ (genCLOZUREnativeTranslation): New.
+ (genImportDeclaration): Use it.
+ * interp/vmlisp.lisp (SINTP): Remove duplicate definition.
+ (SMINTP): Likewise.
+ (ZERO?): Likewise.
+ (GCMSG): Reorganize definition.
+ (BPINAME): Likewise.
+
+2010-02-07 Gabriel Dos Reis <gdr@cs.tamu.edu>
+
* interp/daase.lisp: Remove conditionals on :CCL.
* interp/fname.lisp: Likewise.
* interp/foam_l.lisp: Likewise.
diff --git a/src/boot/ast.boot b/src/boot/ast.boot
index 5eb147ed..6f3e701f 100644
--- a/src/boot/ast.boot
+++ b/src/boot/ast.boot
@@ -1,6 +1,6 @@
-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
-- All rights reserved.
--- Copyright (C) 2007-2009, Gabriel Dos Reis.
+-- Copyright (C) 2007-2010, Gabriel Dos Reis.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
@@ -1275,43 +1275,50 @@ nativeType t ==
t in '(byte uint8) =>
%hasFeature KEYWORD::SBCL => [bfColonColon("SB-ALIEN","UNSIGNED"),8]
%hasFeature KEYWORD::CLISP => bfColonColon("FFI","UINT8")
- %hasFeature KEYWORD::ECL => KEYWORD::UNSIGNED_-BYTE
+ %hasFeature KEYWORD::ECL or %hasFeature KEYWORD::CLOZURE =>
+ KEYWORD::UNSIGNED_-BYTE
nativeType "char" -- approximate by 'char' for GCL
t = "int16" =>
%hasFeature KEYWORD::SBCL => [bfColonColon("SB-ALIEN","SIGNED"),16]
%hasFeature KEYWORD::CLISP => bfColonColon("FFI","INT16")
%hasFeature KEYWORD::ECL and %hasFeature KEYWORD::UINT16_-T =>
KEYWORD::INT16_-T
+ %hasFeature KEYWORD::CLOZURE => KEYWORD::SIGNED_-HALFWORD
unknownNativeTypeError t
t = "uint16" =>
%hasFeature KEYWORD::SBCL => [bfColonColon("SB-ALIEN","UNSIGNED"),16]
%hasFeature KEYWORD::CLISP => bfColonColon("FFI","UINT16")
%hasFeature KEYWORD::ECL and %hasFeature KEYWORD::UINT16_-T =>
KEYWORD::UINT16_-T
+ %hasFeature KEYWORD::CLOZURE => KEYWORD::UNSIGNED_-HALFWORD
unknownNativeTypeError t
t = "int32" =>
%hasFeature KEYWORD::SBCL => [bfColonColon("SB-ALIEN","SIGNED"),32]
%hasFeature KEYWORD::CLISP => bfColonColon("FFI","INT32")
%hasFeature KEYWORD::ECL and %hasFeature KEYWORD::UINT32_-T =>
KEYWORD::INT32_-T
+ %hasFeature KEYWORD::CLOZURE => KEYWORD::SIGNED_-FULLWORD
unknownNativeTypeError t
t = "uint32" =>
%hasFeature KEYWORD::SBCL => [bfColonColon("SB-ALIEN","UNSIGNED"),32]
%hasFeature KEYWORD::CLISP => bfColonColon("FFI","INT32")
%hasFeature KEYWORD::ECL and %hasFeature KEYWORD::UINT32_-T =>
KEYWORD::UINT32_-T
+ %hasFeature KEYWORD::CLOZURE => KEYWORD::UNSIGNED_-FULLWORD
unknownNativeTypeError t
t = "int64" =>
%hasFeature KEYWORD::SBCL => [bfColonColon("SB-ALIEN","SIGNED"),64]
%hasFeature KEYWORD::CLISP => bfColonColon("FFI","INT64")
%hasFeature KEYWORD::ECL and %hasFeature KEYWORD::UINT64_-T =>
KEYWORD::INT64_-T
+ %hasFeature KEYWORD::CLOZURE => KEYWORD::SIGNED_-DOUBLEWORD
unknownNativeTypeError t
t = "uint64" =>
%hasFeature KEYWORD::SBCL => [bfColonColon("SB-ALIEN","UNSIGNED"),64]
%hasFeature KEYWORD::CLISP => bfColonColon("FFI","UINT64")
%hasFeature KEYWORD::ECL and %hasFeature KEYWORD::UINT64_-T =>
KEYWORD::UINT64_-T
+ %hasFeature KEYWORD::CLOZURE => KEYWORD::UNSIGNED_-DOUBLEWORD
unknownNativeTypeError t
t = "float32" => nativeType "float"
t = "float64" => nativeType "double"
@@ -1320,6 +1327,7 @@ nativeType t ==
%hasFeature KEYWORD::ECL => KEYWORD::POINTER_-VOID
%hasFeature KEYWORD::SBCL => ["*",bfColonColon("SB-ALIEN","VOID")]
%hasFeature KEYWORD::CLISP => bfColonColon("FFI","C-POINTER")
+ %hasFeature KEYWORD::CLOZURE => KEYWORD::ADDRESS
unknownNativeTypeError t
unknownNativeTypeError t
-- composite, reference type.
@@ -1328,13 +1336,13 @@ nativeType t ==
%hasFeature KEYWORD::ECL => KEYWORD::OBJECT
%hasFeature KEYWORD::SBCL => ["*",nativeType second t]
%hasFeature KEYWORD::CLISP => bfColonColon("FFI","C-POINTER")
+ %hasFeature KEYWORD::CLOZURE => [KEYWORD::_*, nativeType second t]
unknownNativeTypeError t
first t = "pointer" =>
-- we don't bother looking at what the pointer points to.
nativeType "pointer"
unknownNativeTypeError t
-
++ Check that `t' is a valid return type for a native function, and
++ returns its translation
nativeReturnType t ==
@@ -1342,7 +1350,6 @@ nativeReturnType t ==
coreError strconc('"invalid return type for native function: ",
SYMBOL_-NAME t)
-
++ Check that `t' is a valid parameter type for a native function,
++ and returns its translation.
nativeArgumentType t ==
@@ -1363,7 +1370,6 @@ nativeArgumentType t ==
coreError '"expected simple native data type"
nativeType second t
-
++ True if objects of type native type `t' are sensible to GC.
needsStableReference? t ==
t is [m,:.] and m in '(readonly writeonly readwrite)
@@ -1371,9 +1377,9 @@ needsStableReference? t ==
++ coerce argument `a' to native type `t', in preparation for
++ a call to a native functions.
coerceToNativeType(a,t) ==
- -- GCL, ECL, and CLISP don't do it this way.
+ -- GCL, ECL, CLISP, and CLOZURE don't do it this way.
%hasFeature KEYWORD::GCL or %hasFeature KEYWORD::ECL
- or %hasFeature KEYWORD::CLISP => a
+ or %hasFeature KEYWORD::CLISP or %hasFeature KEYWORD::CLOZURE => a
%hasFeature KEYWORD::SBCL =>
not needsStableReference? t => a
[.,[c,y]] := t
@@ -1483,7 +1489,7 @@ genCLISPnativeTranslation(op,s,t,op') ==
parms := [GENSYM '"parm" for x in s] -- parameters of the forward decl.
-- Now, separate non-simple data from the rest. This is a triple-list
- -- of the form ((parameter boot-time . ffi-type) ...)
+ -- of the form ((parameter boot-type . ffi-type) ...)
unstableArgs := nil
for p in parms for x in s for y in argtypes repeat
needsStableReference? x =>
@@ -1563,6 +1569,57 @@ genSBCLnativeTranslation(op,s,t,op') ==
["FUNCTION",rettype,:argtypes]], :nreverse newArgs]]]]
+
+++ Generate Clozure CL's equivalent of import declaration
+genCLOZUREnativeTranslation(op,s,t,op') ==
+ -- check parameter types and return types.
+ rettype := nativeReturnType t
+ argtypes := [nativeArgumentType x for x in s]
+
+ -- Build parameter list for the forwarding function
+ parms := [GENSYM '"parm" for x in s]
+
+ -- Separate string arguments and array arguments from scalars.
+ -- These array arguments need to be pinned down, and the string
+ -- arguments need to stored in a stack-allocaed NTBS.
+ strPairs := nil
+ aryPairs := nil
+ for p in parms for x in s repeat
+ x = "string" => strPairs := [[p,:GENSYM '"loc"], :strPairs]
+ x is [.,["buffer",.]] => aryPairs := [[p,:GENSYM '"loc"], :aryPairs]
+
+ -- Build the actual foreign function call.
+ -- Note that Clozure CL does not mangle foreign function call for
+ -- us, so we're left with more platform dependencies than needed.
+ if %hasFeature KEYWORD::DARWIN then
+ op' := strconc("__",op')
+ call := [bfColonColon("CCL","EXTERNAL-CALL"), STRING op', :args, rettype]
+ where
+ args() == [:[x, parm] for x in argtypes for p in parms]
+ parm() ==
+ p' := ASSOC(p, strPairs) => rest p'
+ p' := ASSOC(p, aryPairs) => rest p'
+ p
+
+ -- If the foreign call returns a C-string, turn it into a Lisp string.
+ -- Note that if the C-string was malloc-ed, this will leak storage.
+ if t = "string" then
+ call := [bfColonColon("CCL","GET-CSTRING"), call]
+
+ -- If we have array arguments from Boot, bind pointers to initial data.
+ for arg in aryPairs repeat
+ call := [bfColonColon("CCL", "WITH-POINTER-TO-IVECTOR"),
+ [rest arg, first arg], call]
+
+ -- Finally, if we have string arguments from Boot, copy them to
+ -- stack-allocated NTBS.
+ if strPairs ~= nil then
+ call := [bfColonColon("CCL", "WITH-CSTRS"),
+ [[rest arg, first arg] for arg in strPairs], call]
+
+ -- Finally, return the definition form
+ [["DEFUN", op, parms, call]]
+
++ Generate an import declaration for `op' as equivalent of the
++ foreign signature `sig'. Here, `foreign' operationally means that
++ the entity is from the C language world.
@@ -1575,6 +1632,7 @@ genImportDeclaration(op, sig) ==
%hasFeature KEYWORD::SBCL => genSBCLnativeTranslation(op,s,t,op')
%hasFeature KEYWORD::CLISP => genCLISPnativeTranslation(op,s,t,op')
%hasFeature KEYWORD::ECL => genECLnativeTranslation(op,s,t,op')
+ %hasFeature KEYWORD::CLOZURE => genCLOZUREnativeTranslation(op,s,t,op')
fatalError '"import declaration not implemented for this Lisp"
diff --git a/src/boot/translator.boot b/src/boot/translator.boot
index f931975e..c23debbd 100644
--- a/src/boot/translator.boot
+++ b/src/boot/translator.boot
@@ -1,6 +1,6 @@
-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
-- All rights reserved.
--- Copyright (C) 2007-2009, Gabriel Dos Reis.
+-- Copyright (C) 2007-2010, Gabriel Dos Reis.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
@@ -771,6 +771,8 @@ loadNativeModule m ==
EVAL [bfColonColon("FFI","DEFAULT-FOREIGN-LIBRARY"), m]
%hasFeature KEYWORD::ECL =>
EVAL [bfColonColon("FFI","LOAD-FOREIGN-LIBRARY"), m]
+ %hasFeature KEYWORD::CLOZURE =>
+ EVAL [bfColonColon("CCL","OPEN-SHARED-LIBRARY"), m]
coreError '"don't know how to load a dynamically linked module"
loadSystemRuntimeCore() ==
diff --git a/src/driver/utils.h b/src/driver/utils.h
index 89aa81aa..83c168ae 100644
--- a/src/driver/utils.h
+++ b/src/driver/utils.h
@@ -1,5 +1,5 @@
/*
- Copyright (C) 2008-2009, Gabriel Dos Reis.
+ Copyright (C) 2008-2010, Gabriel Dos Reis.
All rights reserved.
Redistribution and use in source and binary forms, with or without
@@ -60,6 +60,7 @@ typedef enum openaxiom_runtime {
openaxiom_sbcl_runtime,
openaxiom_clisp_runtime,
openaxiom_ecl_runtime,
+ openaxiom_clozure_runtime,
openaxiom_bemol_runtime
} openaxiom_runtime;
diff --git a/src/interp/i-syscmd.boot b/src/interp/i-syscmd.boot
index e17d6f65..b2d70fd2 100644
--- a/src/interp/i-syscmd.boot
+++ b/src/interp/i-syscmd.boot
@@ -2380,7 +2380,7 @@ savesystem l ==
)if not %hasFeature KEYWORD::ECL
AxiomCore::saveCore SYMBOL_-NAME first l
)else
- fatalError '"don't know how to same image"
+ fatalError '"don't know how to save image"
)endif
--% )show
diff --git a/src/interp/vmlisp.lisp b/src/interp/vmlisp.lisp
index e7bedb34..811b7069 100644
--- a/src/interp/vmlisp.lisp
+++ b/src/interp/vmlisp.lisp
@@ -469,15 +469,9 @@
(defmacro sintp (n)
`(typep ,n 'fixnum))
-(defmacro sintp (n)
- `(fixp ,n))
-
(defmacro smintp (n)
`(typep ,n 'fixnum))
-(defmacro smintp (n)
- `(fixp ,n))
-
(defmacro stringlength (x)
`(length (the string ,x)))
@@ -498,8 +492,6 @@
(defmacro zero? (x)
`(and (typep ,x 'fixnum) (zerop (the fixnum ,x))))
-(defmacro zero? (x) `(zerop ,x))
-
;; defuns
(define-function 'tempus-fugit #'get-internal-run-time)
@@ -1693,66 +1685,57 @@
(defun |read-line| (st &optional (eofval *read-place-holder*))
(read-line st nil eofval))
-#+Lucid
-(defun gcmsg (x)
- (prog1 (not system::*gc-silence*) (setq system::*gc-silence* (not x))))
-#+(OR IBCL KCL)
-(defun gcmsg (x)
- (prog1 system:*gbc-message* (setq system:*gbc-message* x)))
-#+:cmulisp
(defun gcmsg (x)
- (prog1 ext:*gc-verbose* (setq ext:*gc-verbose* x)))
-#+ (or :allegro :sbcl :clisp :ecl)
-(defun gcmsg (x))
-
-#+Lucid
-(defun reclaim () (system:gc))
-#+:cmulisp
-(defun reclaim () (ext:gc))
-#+(OR IBCL KCL)
-(defun reclaim () (gbc t))
-#+:allegro
-(defun reclaim () (excl::gc t))
+ #+Lucid
+ (prog1 (not system::*gc-silence*)
+ (setq system::*gc-silence* (not x)))
+ #+(OR IBCL KCL)
+ (prog1 system:*gbc-message*
+ (setq system:*gbc-message* x))
+ #+:cmulisp
+ (prog1 ext:*gc-verbose*
+ (setq ext:*gc-verbose* x))
+ )
+
+(defun reclaim ()
+ #+Lucid (system:gc)
+ #+:cmulisp (ext:gc)
+ #+(OR IBCL KCL) (gbc t)
+ #+:allegro (excl::gc t)
+ )
-#+Lucid
-(defun BPINAME (func)
- (if (functionp func)
- (if (symbolp func) func
- (let ((name (svref func 0)))
- (if (and (consp name) (eq (car name) 'SYSTEM::NAMED-LAMBDA))
- (cadr name)
- name)) )))
-
-#+(OR IBCL KCL)
-(defun BPINAME (func)
- (if (functionp func)
- (cond ((symbolp func) func)
- ((and (consp func) (eq (car func) 'LAMBDA-BLOCK))
- (cadr func))
- ((compiled-function-p func)
- (system:compiled-function-name func))
- ('t func))))
-#+:cmulisp
-(defun BPINAME (func)
- (when (functionp func)
- (cond
- ((symbolp func) func)
- ((and (consp func) (eq (car func) 'lambda)) (second (third func)))
- ((compiled-function-p func)
- (system::%primitive header-ref func system::%function-name-slot))
- ('else func))))
-#+:allegro
(defun bpiname (func)
- func)
-
-#+(or :SBCL :clisp :ecl)
-(defun BPINAME (x)
- (if (symbolp x)
- x
- (multiple-value-bind (l c n)
- (function-lambda-expression x)
- (declare (ignore l c))
- n)))
+ #+Lucid (if (functionp func)
+ (if (symbolp func) func
+ (let ((name (svref func 0)))
+ (if (and (consp name) (eq (car name) 'SYSTEM::NAMED-LAMBDA))
+ (cadr name)
+ name))))
+
+ #+(OR IBCL KCL) (if (functionp func)
+ (cond ((symbolp func) func)
+ ((and (consp func) (eq (car func) 'LAMBDA-BLOCK))
+ (cadr func))
+ ((compiled-function-p func)
+ (system:compiled-function-name func))
+ ('t func)))
+ #+:cmulisp (when (functionp func)
+ (cond
+ ((symbolp func) func)
+ ((and (consp func)
+ (eq (car func) 'lambda))
+ (second (third func)))
+ ((compiled-function-p func)
+ (system::%primitive header-ref func
+ system::%function-name-slot))
+ ('else func)))
+ #+:allegro func
+ #+(or :SBCL :clisp :ecl :clozure) (if (symbolp func)
+ func
+ (multiple-value-bind (l c n)
+ (function-lambda-expression func)
+ (declare (ignore l c))
+ n)))
(defun RE-ENABLE-INT (number-of-handler) number-of-handler)
diff --git a/src/lisp/core.lisp.in b/src/lisp/core.lisp.in
index d12723b4..1d4882ad 100644
--- a/src/lisp/core.lisp.in
+++ b/src/lisp/core.lisp.in
@@ -3,7 +3,7 @@
;; Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
;; All rights reserved.
;;
-;; Copyright (C) 2007-2009, Gabriel Dos Reis.
+;; Copyright (C) 2007-2010, Gabriel Dos Reis.
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
@@ -190,7 +190,9 @@
#+:ecl #'si::top-level
#+:gcl #'si::top-level
#+:sbcl #'sb-impl::toplevel-init
- #+clisp #'system::main-loop)
+ #+clisp #'system::main-loop
+ #+:clozure nil ; don't know, kept private
+ )
;; Lisp source file extension.
(defconstant |$LispFileType| "lisp")
@@ -404,7 +406,6 @@
option)))))
(values options-so-far argv)))
-
;;
;; -*- Building New Lisp Images -*-
;;
@@ -468,6 +469,12 @@
:norc t
))
(ext::quit))
+ #+:clozure (progn
+ (ccl:save-application core-image
+ :toplevel-function entry-point
+ :error-handler :quit
+ :prepend-kernel t)
+ (return-from |saveCore|))
(error "don't know how to save Lisp image"))
@@ -489,7 +496,8 @@
#+:clisp (ext:quit status)
#+:gcl (si::bye status)
#+:ecl (ext:quit status)
- #-(or :sbcl :clisp :gcl :ecl)
+ #+:clozure (ccl:quit status)
+ #-(or :sbcl :clisp :gcl :ecl :clozure)
(error "`coreQuit' not implemented for this Lisp"))
@@ -592,9 +600,10 @@
;; Command line arguments: equivalent of traditional `argv[]' from
;; systems programming world.
(defun |getCommandLineArguments| nil
- #-(or :gcl :sbcl :clisp :ecl)
+ #-(or :gcl :sbcl :clisp :ecl :clozure)
(|fatalError| "don't know how to get command line args")
(let* ((all-args
+ #+:clozure ccl:*command-line-argument-list*
#+:ecl (ext:command-args)
#+:gcl si::*command-args*
#+:sbcl sb-ext::*posix-argv*
@@ -604,31 +613,6 @@
;;
-;; -*- Program Startup -*-
-;;
-
-;; The top level entry point to most saved Lisp image.
-(defun |main| nil
- (setq *package* (find-package "BOOT"))
- ;; Existing system programming practive, and POSIX, have it
- ;; that the first argument on the command line is the name
- ;; of the current instantiation of the program.
- ;; We require at least two arguments:
- ;; (0) the program name
- ;; (1) either one of --help or --version, or
- ;; a filename.
- (let ((command-args (|getCommandLineArguments|)))
- (when (null command-args)
- (|internalError| "empty command line args"))
- (when (fboundp '|main|)
- (|coreQuit| (funcall '|main| command-args)))
-
- ;; Huh, the main entry point was not defined.
- (|fatalError| "missing definition for main function")
- (|coreQuit| 1)))
-
-
-;;
;; -*- Building Standalone Executable -*-
;;
;; Build a standalone excutable from LISP-FILES -- a list of
@@ -715,6 +699,7 @@
)
+
;;
;; -*- --help Handler -*-
;;
@@ -887,7 +872,7 @@
;; Run the system-specific initialization.
(when (fboundp '|%sysInit|)
- (funcall '|%sysInit|))
+ (funcall (symbol-function '|%sysInit|)))
(when (|handleCommandLine| (car command-args) options args)
(|coreQuit| (if (> (|errorCount|) 0) 1 0))))))