archive/src/init_maxima.lsp

   1 (in-package "COMPILER")
   2 (in-package "SYSTEM")
   3 (defvar *command-args* nil)
   4 (in-package "USER")
   5 (in-package "LISP")
   6
   7 (lisp::in-package "SLOOP")
   8
   9 ;;Appropriate for Austin
  10 (setq SYSTEM:*DEFAULT-TIME-ZONE*  6)
  11 (in-package "USER")
  12 (load "../gcl-tk/tk-package.lsp")
  13 (progn (allocate 'cons 100) (allocate 'string 40)
  14  (system:init-system) (gbc t)
  15 #+gmp (defun si::multiply-bignum-stack (n) "nothing")
  16  (si::multiply-bignum-stack 25)
  17  (or lisp::*link-array*
  18   (setq lisp::*link-array*
  19      (make-array (ash 1 11)  :element-type 'string-char :fill-pointer 0)))
  20  (si::use-fast-links t)
  21 (setq compiler::*cmpinclude* "<cmpinclude.h>") (load #"../cmpnew/cmpmain.lsp") (gbc t)
  22  (load #"../cmpnew/lfun_list.lsp")
  23  (gbc t) (load #"../cmpnew/cmpopt.lsp") (gbc t)
  24 (load #"../lsp/auto.lsp") (gbc t)
  25
  26  (when compiler::*cmpinclude-string*
  27   (with-open-file (st "../h/cmpinclude.h")
  28     (let
  29         ((tem (make-array (file-length st) :element-type 'standard-char
  30                           :static t)))
  31       (if (si::fread tem 0 (length tem) st)
  32           (setq compiler::*cmpinclude-string* tem)))))
  33  ;;compile-file is in cmpmain.lsp
  34
  35  (setf (symbol-function 'si:clear-compiler-properties)
  36        (symbol-function 'compiler::compiler-clear-compiler-properties))
  37 ; (load "../lsp/setdoc.lsp")
  38  (setq system::*old-top-level* (symbol-function 'system:top-level))
  39
  40 (defvar si::*lib-directory* (namestring "../"))
  41
  42
  43
  44 (defun system::gcl-top-level (&aux tem)
  45   (si::set-up-top-level)
  46
  47   (if (si::get-command-arg "-compile")
  48         (let (;(system::*quit-tag* (cons nil nil))
  49               ;(system::*quit-tags* nil) (system::*break-level* '())
  50               ;(system::*break-env* nil) (system::*ihs-base* 1)
  51               ;(system::*ihs-top* 1) (system::*current-ihs* 1)
  52               (*break-enable* nil) result)
  53              (setq result
  54                    (system:error-set
  55                     '(progn
  56                        (compile-file
  57                         (si::get-command-arg "-compile")
  58                         :output-file
  59                         (or (si::get-command-arg "-o")
  60                             (si::get-command-arg "-compile"))
  61                         :o-file
  62                         (cond ((equalp
  63                                 (si::get-command-arg "-o-file")
  64                                 "nil") nil)
  65                               ((si::get-command-arg "-o-file" t))
  66                               (t t))
  67                         :c-file (si::get-command-arg "-c-file" t)
  68                         :h-file (si::get-command-arg "-h-file" t)
  69                         :data-file (si::get-command-arg "-data-file" t)
  70                         :system-p (si::get-command-arg "-system-p" t)))))
  71              (bye (if (or compiler::*error-p* (equal result '(nil))) 1 0))))
  72   (cond ((si::get-command-arg "-batch")
  73          (setq si::*top-level-hook* 'bye))
  74         ((si::get-command-arg "-f"))
  75         (t  ;; if ANY header or license information is printed by the
  76             ;; program, then the following License and Enhancement notice
  77             ;; must be printed (see License).
  78          (format t "GCL (GNU Common Lisp)  ~A~%~a~%~a~%" "DATE"
  79                  "Licensed under GNU Library General Public License"
  80                  "Contains Enhancements by W. Schelter")))
  81      (setq si::*ihs-top* 1)
  82   (in-package 'system::user) (incf system::*ihs-top* 2)
  83   (funcall system::*old-top-level*))
  84  (setq si::*gcl-version* 600)
  85  (defun lisp-implementation-version nil (format nil "GCL-1-~a" si::*gcl-version*))
  86  (terpri)
  87  (setq si:*inhibit-macro-special* t)
  88  ;(setq *modules* nil)
  89  (gbc t) (system:reset-gbc-count)
  90  (allocate 'cons 200)
  91  (defun system:top-level nil (system::gcl-top-level))
  92  (unintern 'system)
  93  (unintern 'lisp)
  94  (unintern 'compiler)
  95  (unintern 'user)
  96  (si::chdir "/home/wfs/cvs/maxima/src")(si::save-system "saved_maxima")
  97  (if (fboundp 'user-init) (user-init))
  98  (si::set-up-top-level)
  99  (in-package "USER")
 100  (system:save-system "saved_gcl") (bye)
 101  (defun system:top-level nil (system::gcl-top-level))
 102  (save "saved_gcl") (bye))
 103