From 3f8f61e055c818711c6a6136b89b6e9fedda8c3c Mon Sep 17 00:00:00 2001
From: dos-reis <gdr@axiomatics.org>
Date: Mon, 8 Feb 2010 01:08:42 +0000
Subject: 	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.

---
 src/lisp/core.lisp.in | 47 ++++++++++++++++-------------------------------
 1 file changed, 16 insertions(+), 31 deletions(-)

(limited to 'src/lisp/core.lisp.in')

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*
@@ -603,31 +612,6 @@
     (cons (car all-args) (if args (cdr args) args))))
 
 
-;; 
-;; -*- 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 -*-
 ;; 
@@ -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))))))
-- 
cgit v1.2.3