home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / unixport / init_gcl.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-05-10  |  3.5 KB  |  92 lines
  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. ;;Appropriate for Austin
  9. (setq SYSTEM:*DEFAULT-TIME-ZONE*  6)
  10. (in-package "USER")
  11. (progn (allocate 'cons 100) (allocate 'string 40)
  12.  (system:init-system) (gbc t)
  13.  (si::multiply-bignum-stack 25)
  14.  (or lisp::*link-array*
  15.   (setq lisp::*link-array*
  16.      (make-array 500 :element-type 'fixnum :fill-pointer 0)))
  17.  (use-fast-links t)
  18. (setq compiler::*cmpinclude* "<cmpinclude.h>") (load #"../cmpnew/cmpmain.lsp") (gbc t) (load #"../cmpnew/lfun_list.lsp")
  19.  (gbc t) (load #"../cmpnew/cmpopt.lsp") (gbc t)
  20. (load #"../lsp/auto.lsp") (gbc t)
  21. (defun si::src-path (x)
  22.   (si::string-concatenate (or si::*lib-directory* "GCLDIR/") x))
  23.  
  24.  (when compiler::*cmpinclude-string*
  25.   (with-open-file (st "../h/cmpinclude.h")
  26.     (let
  27.     ((tem (make-array (file-length st) :element-type 'standard-char
  28.               :static t)))
  29.       (if (si::fread tem 0 (length tem) st)
  30.       (setq compiler::*cmpinclude-string* tem)))))
  31.  ;;compile-file is in cmpmain.lsp
  32.  
  33.  (setf (symbol-function 'si:clear-compiler-properties)
  34.        (symbol-function 'compiler::compiler-clear-compiler-properties))
  35. ; (load "../lsp/setdoc.lsp")
  36.  (setq system::*old-top-level* (symbol-function 'system:top-level))
  37. (defvar si::*command-args* nil)
  38. (defun si::get-command-arg (a &optional val-if-there)
  39.   ;; return non nil if a is in si::*command-args* and return
  40.   ;; the string which is after it if there is one"
  41.   (let ((tem (member a si::*command-args* :test 'equal)))
  42.     (if tem (or  val-if-there (cadr tem) t))))
  43. (defvar si::*lib-directory* nil)
  44. (defun system::gcl-top-level (&aux tem)
  45.   (dotimes (i (si::argc))
  46.        (setq si::*command-args* (cons (si::argv i) si::*command-args*)))
  47.   (setq si::*command-args* (nreverse si::*command-args* ))
  48.   (setq si::*system-directory*
  49.     (or (si::get-command-arg "-dir")
  50.         (car si::*command-args*)))
  51.   (setq si::*lib-directory* (si::get-command-arg "-libdir"))
  52.     
  53.   (when (si::get-command-arg "-compile")
  54.         (let ((system::*quit-tag* (cons nil nil))
  55.               (system::*quit-tags* nil) (system::*break-level* '())
  56.               (system::*break-env* nil) (system::*ihs-base* 1)
  57.               (system::*ihs-top* 1) (system::*current-ihs* 1)
  58.               (*break-enable* nil))
  59.              (system:error-set
  60.               '(progn
  61.          (compile-file (si::get-command-arg "-compile")
  62.                    :output-file 
  63.                    (or (si::get-command-arg "-o")
  64.                    (si::get-command-arg "-compile"))
  65.                    :o-file (not (si::get-command-arg "-no-o" t))
  66.                    :c-file (si::get-command-arg "-system-p" t)
  67.                    :h-file (si::get-command-arg "-system-p" t)
  68.                    :data-file (si::get-command-arg "-system-p" t)
  69.                    :system-p (si::get-command-arg "-system-p" t))))
  70.              (bye (if compiler::*error-p* 1 0))))
  71.   (format t "GCL (GNU Common Lisp)  ~A~%~a~%~a~%" "DATE"
  72.       "Licensed under GNU Public Library License"
  73.         "Contains Enhancements by W. Schelter")
  74.      (setq si::*ihs-top* 1)
  75.   (in-package 'system::user) (incf system::*ihs-top* 2)
  76.   (funcall system::*old-top-level*))
  77.  (setq si::*gcl-version* 600) 
  78.  (defun lisp-implementation-version nil (format nil "1-~a" si::*gcl-version*))
  79.  (setq si:*inhibit-macro-special* t)
  80.  ;(setq *modules* nil)
  81.  (gbc t) (system:reset-gbc-count)
  82.  (allocate 'cons 200)
  83.  (defun system:top-level nil (system::gcl-top-level))
  84.  (unintern 'system)
  85.  (unintern 'lisp)
  86.  (unintern 'compiler)
  87.  (unintern 'user)
  88.  (system:save-system "saved_gcl") (bye)
  89.  (defun system:top-level nil (system::gcl-top-level))
  90.  (save "saved_gcl") (bye))
  91.  
  92.