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

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

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

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

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

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