/[gcl]/gcl/unixport/init_gcl.lsp.in
ViewVC logotype

Diff of /gcl/unixport/init_gcl.lsp.in

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.8 by mjthomas, Mon Dec 30 04:22:11 2002 UTC revision 1.9 by camm, Wed Feb 26 22:21:43 2003 UTC
# Line 1  Line 1 
1  (make-package "COMPILER" :use '("LISP"))  (make-package "COMPILER" :use '("LISP"))
 (in-package "SYSTEM")  
 (defvar *command-args* nil)  
 (in-package "USER")  
 (in-package "LISP")  
   
2  (make-package "SLOOP" :use '("LISP"))  (make-package "SLOOP" :use '("LISP"))
3  (make-package "SERROR" :use '("LISP" "SLOOP"))  (make-package "SERROR" :use '("LISP" "SLOOP"))
4  (make-package "ANSI-LOOP" :use '("LISP"))  (make-package "ANSI-LOOP" :use '("LISP"))
5  (make-package "DEFPACKAGE" :use '("LISP"))  (make-package "DEFPACKAGE" :use '("LISP"))
6  (make-package "TK" :use '("LISP" "SLOOP"))  (make-package "TK" :use '("LISP" "SLOOP"))
7    
8  (eval-when (load)  (in-package "SYSTEM")
9      (if (fboundp 'get-system-time-zone)  (defvar *command-args* nil)
         (setf system:*default-time-zone* (get-system-time-zone))  
        (setf system:*default-time-zone* 6)))  
10    
 (in-package "USER")  
11  (progn  (progn
12   (system:init-system) (gbc t)   (system:init-system)
13     (gbc t)
14    
15     (in-package "USER")
16    
17   (load (concatenate 'string si::*system-directory* "../gcl-tk/tk-package.lsp"))   (load (concatenate 'string si::*system-directory* "../gcl-tk/tk-package.lsp"))
18    
19   (or lisp::*link-array*   (or lisp::*link-array*
20    (setq lisp::*link-array*       (setq lisp::*link-array*
21       (make-array (ash 1 11)  :element-type 'string-char :fill-pointer 0)))             (make-array (ash 1 11)  :element-type 'string-char :fill-pointer 0)))
22   (si::use-fast-links t)   (si::use-fast-links t)
23    
24   (setq compiler::*cmpinclude* "\"cmpinclude.h\"")   (setq compiler::*cmpinclude* "\"cmpinclude.h\"")
25    
26   (load (concatenate 'string si::*system-directory* "../cmpnew/cmpmain.lsp"))   (load (concatenate 'string si::*system-directory* "../cmpnew/cmpmain.lsp"))
27   (gbc t)   (gbc t)
28   (load (concatenate 'string si::*system-directory* "../cmpnew/lfun_list.lsp"))   (load (concatenate 'string si::*system-directory* "../cmpnew/lfun_list.lsp"))
# Line 33  Line 31 
31   (gbc t)   (gbc t)
32   (load (concatenate 'string si::*system-directory* "../lsp/auto_new.lsp"))   (load (concatenate 'string si::*system-directory* "../lsp/auto_new.lsp"))
33   (gbc t)   (gbc t)
34    
35   (when compiler::*cmpinclude-string*   (when compiler::*cmpinclude-string*
36    (with-open-file (st (concatenate 'string si::*system-directory* "../h/cmpinclude.h"))     (with-open-file (st (concatenate 'string si::*system-directory* "../h/cmpinclude.h"))
37      (let                     (let
38          ((tem (make-array (file-length st) :element-type 'standard-char                         ((tem (make-array (file-length st) :element-type 'standard-char
39                            :static t)))                                           :static t)))
40        (if (si::fread tem 0 (length tem) st)                       (if (si::fread tem 0 (length tem) st)
41            (setq compiler::*cmpinclude-string* tem)))))                           (setq compiler::*cmpinclude-string* tem)))))
42    
43   (setf (symbol-function 'si:clear-compiler-properties)   (setf (symbol-function 'si:clear-compiler-properties)
44         (symbol-function 'compiler::compiler-clear-compiler-properties))         (symbol-function 'compiler::compiler-clear-compiler-properties))
45   (setq system::*old-top-level* (symbol-function 'system:top-level))   (setq system::*old-top-level* (symbol-function 'system:top-level))
46    
47  (defvar si::*lib-directory* (namestring "../"))   (defvar si::*lib-directory* (namestring "../"))
48    
49           (defun system::gcl-top-level (&aux tem)
50       (si::set-up-top-level)
51  (defun system::gcl-top-level (&aux tem)    
52    (si::set-up-top-level)     (if (si::get-command-arg "-compile")
53           (let (;(system::*quit-tag* (cons nil nil))
54    (if (si::get-command-arg "-compile")                                          ;(system::*quit-tags* nil) (system::*break-level* '())
55          (let (;(system::*quit-tag* (cons nil nil))                                          ;(system::*break-env* nil) (system::*ihs-base* 1)
56                ;(system::*quit-tags* nil) (system::*break-level* '())                                          ;(system::*ihs-top* 1) (system::*current-ihs* 1)
57                ;(system::*break-env* nil) (system::*ihs-base* 1)               (*break-enable* nil) result)
58                ;(system::*ihs-top* 1) (system::*current-ihs* 1)           (setq result
59                (*break-enable* nil) result)                 (system:error-set
60               (setq result                  '(progn
61                     (system:error-set                     (compile-file
62                      '(progn                      (si::get-command-arg "-compile")
63                         (compile-file                      :output-file
64                          (si::get-command-arg "-compile")                      (or (si::get-command-arg "-o")
65                          :output-file                          (si::get-command-arg "-compile"))
66                          (or (si::get-command-arg "-o")                      :o-file
67                              (si::get-command-arg "-compile"))                      (cond ((equalp
68                          :o-file                              (si::get-command-arg "-o-file")
69                          (cond ((equalp                              "nil") nil)
70                                  (si::get-command-arg "-o-file")                            ((si::get-command-arg "-o-file" t))
71                                  "nil") nil)                            (t t))
72                                ((si::get-command-arg "-o-file" t))                      :c-file (si::get-command-arg "-c-file" t)
73                                (t t))                      :h-file (si::get-command-arg "-h-file" t)
74                          :c-file (si::get-command-arg "-c-file" t)                      :data-file (si::get-command-arg "-data-file" t)
75                          :h-file (si::get-command-arg "-h-file" t)                      :system-p (si::get-command-arg "-system-p" t)))))
76                          :data-file (si::get-command-arg "-data-file" t)           (bye (if (or compiler::*error-p* (equal result '(nil))) 1 0))))
77                          :system-p (si::get-command-arg "-system-p" t)))))     (cond ((si::get-command-arg "-batch")
78               (bye (if (or compiler::*error-p* (equal result '(nil))) 1 0))))            (setq si::*top-level-hook* 'bye))
79    (cond ((si::get-command-arg "-batch")           ((si::get-command-arg "-f"))
80           (setq si::*top-level-hook* 'bye))           (t  ;; if ANY header or license information is printed by the
81          ((si::get-command-arg "-f"))            ;; program, then the following License and Enhancement notice
82          (t  ;; if ANY header or license information is printed by the            ;; must be printed (see License).
83              ;; program, then the following License and Enhancement notice            (format t "GCL (GNU Common Lisp)  ~A~%~a~%~a~%~%~a~%" "@LI-VERS@"
84              ;; must be printed (see License).                    "Licensed under GNU Library General Public License"
85           (format t "GCL (GNU Common Lisp)  ~A~%~a~%~a~%~%~a~%" "DATE"                    "Contains Enhancements by W. Schelter"
86                   "Licensed under GNU Library General Public License"                    "Use (help) to get some basic information on how to use GCL.")))
87                   "Contains Enhancements by W. Schelter"     (setq si::*ihs-top* 1)
88                   "Use (help) to get some basic information on how to use GCL.")))     (in-package 'system::user) (incf system::*ihs-top* 2)
89       (setq si::*ihs-top* 1)     (funcall system::*old-top-level*))
90    (in-package 'system::user) (incf system::*ihs-top* 2)  
   (funcall system::*old-top-level*))  
   
91   (defun lisp-implementation-version nil (format nil "GCL-~a-~a" si::*gcl-major-version* si::*gcl-version*))   (defun lisp-implementation-version nil (format nil "GCL-~a-~a" si::*gcl-major-version* si::*gcl-version*))
92    
93   (terpri)   (terpri)
94   (setq si:*inhibit-macro-special* t)   (setq si:*inhibit-macro-special* t)
95   (gbc t) (system:reset-gbc-count)   (gbc t) (system:reset-gbc-count)
96    
97   (defun system:top-level nil (system::gcl-top-level))   (defun system:top-level nil (system::gcl-top-level))
98    
99     (setq compiler::*default-c-file* nil)
100     (setq compiler::*default-h-file* nil)
101     (setq compiler::*default-data-file* nil)
102     (setq compiler::*default-system-p* nil)
103     (setq compiler::*keep-gaz* nil)
104    
105   (unintern 'system)   (unintern 'system)
106   (unintern 'lisp)   (unintern 'lisp)
107   (unintern 'compiler)   (unintern 'compiler)
108   (unintern 'user)   (unintern 'user)
109     (fmakunbound 'si::init-cmp-anon)
110    
111     (eval-when (load)
112                (if (fboundp 'get-system-time-zone)
113                    (setf system:*default-time-zone* (get-system-time-zone))
114                  (setf system:*default-time-zone* 6)))
115    
116   (if (fboundp 'si::user-init) (si::user-init))   (if (fboundp 'si::user-init) (si::user-init))
117   (si::set-up-top-level))   (si::set-up-top-level)
118  ; (in-package "USER")  
119  ; (system:save-system "saved_gcl") (bye)   (setq si::*gcl-version* @LI-MINVERS@ si::*gcl-major-version* @LI-MAJVERS@)
120     (setq compiler::*cc* @LI-CC@)
121  ;   (setq compiler::*ld* @LI-LD@)
122  ; FIXME Leave the following in until maxima 5.6 is replaced   (setq compiler::*ld-libs* @LI-LD-LIBS@)
123  ;   (setq compiler::*opt-three* @LI-OPT-THREE@)
124  ;system-init   (setq compiler::*opt-two* @LI-OPT-TWO@)
125     (setq compiler::*init-lsp* @LI-INIT-LSP@)
126    
127     t)

Legend:
Removed from v.1.8  
changed lines
  Added in v.1.9

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26