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 / gcldos.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-05-07  |  3.4 KB  |  85 lines
  1. (in-package "COMPILER")
  2. (in-package "SYSTEM")
  3. (in-package "USER")
  4. (in-package "LISP")
  5.  
  6. (lisp::in-package "SLOOP")
  7. ;;Appropriate for Austin
  8. (setq SYSTEM:*DEFAULT-TIME-ZONE*  6)
  9.  
  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)(setq compiler::*cc* "gcc -DVOL=volatile")(si::build-symbol-table)
  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) (si::string-concatenate "/gcl/" x))
  22.  (when compiler::*cmpinclude-string*
  23.   (with-open-file (st "../h/cmpinclude.h")
  24.     (let
  25.     ((tem (make-array (file-length st) :element-type 'standard-char
  26.               :static t)))
  27.       (if (si::fread tem 0 (length tem) st)
  28.       (setq compiler::*cmpinclude-string* tem)))))
  29.  ;;compile-file is in cmpmain.lsp
  30.  
  31.  (setf (symbol-function 'si:clear-compiler-properties)
  32.        (symbol-function 'compiler::compiler-clear-compiler-properties))
  33. ; (load "../lsp/setdoc.lsp")
  34.  (setq system::*old-top-level* (symbol-function 'system:top-level))
  35.  (defun system::gcl-top-level nil
  36.   (when (> (system:argc) 1)
  37.         (setq system:*system-directory* (system:argv 1)))
  38.   (when (>= (system:argc) 5)
  39.         (let ((system::*quit-tag* (cons nil nil))
  40.               (system::*quit-tags* nil) (system::*break-level* '())
  41.               (system::*break-env* nil) (system::*ihs-base* 1)
  42.               (system::*ihs-top* 1) (system::*current-ihs* 1)
  43.               (*break-enable* nil))
  44.              (system:error-set
  45.               '(let ((system::flags (system:argv 4)))
  46.                     (setq system:*system-directory*
  47.                           (pathname (system:argv 1)))
  48.                     (compile-file (system:argv 2) :output-file
  49.                      (system:argv 3) :o-file
  50.                      (case (schar system::flags 1) (#\0 nil) (#\1 t)
  51.                            (t (system:argv 5)))
  52.                      :c-file
  53.                      (case (schar system::flags 2) (#\0 nil) (#\1 t)
  54.                            (t (system:argv 6)))
  55.                      :h-file
  56.                      (case (schar system::flags 3) (#\0 nil) (#\1 t)
  57.                            (t (system:argv 7)))
  58.                      :data-file
  59.                      (case (schar system::flags 4) (#\0 nil) (#\1 t)
  60.                            (t (system:argv 8)))
  61.                      :system-p
  62.                      (if (char-equal (schar system::flags 0) #\S) t
  63.                          nil))))
  64.              (bye (if compiler::*error-p* 1 0))))
  65.   (format t "GCL (GNU Common Lisp)  ~A~%~a~%" "Version(1.617) Tue Nov 24 11:34:34 CST 1992"
  66.         "Contains Enhancements by W. Schelter")
  67.      (setq si::*ihs-top* 1)
  68.  
  69.   (in-package 'system::user) (incf system::*ihs-top* 2)
  70.   (funcall system::*old-top-level*))
  71.  (setq si::*gcl-version* 600) 
  72.  (setq si::*gcl-version* '617)(defun lisp-imp'lementation-version nil (format nil "1-~a" si::*gcl-version*))
  73.  (setq si:*inhibit-macro-special* t)
  74.  ;(setq *modules* nil)
  75.  (gbc t) (system:reset-gbc-count)
  76.  (allocate 'cons 200)
  77.  (defun system:top-level nil (system::gcl-top-level))
  78.  (unintern 'system)
  79.  (unintern 'lisp)
  80.  (unintern 'compiler)
  81.  (unintern 'user)
  82.  (system:save-system "saved_gcl") (bye)
  83.  (defun system:top-level nil (system::gcl-top-level))
  84.  (save "saved_gcl") (bye))
  85.