1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
|
(make-package "COMPILER" :use '("LISP"))
(make-package "SLOOP" :use '("LISP"))
(make-package "SERROR" :use '("LISP" "SLOOP"))
(make-package "ANSI-LOOP" :use '("LISP"))
(make-package "DEFPACKAGE" :use '("LISP"))
(make-package "TK" :use '("LISP" "SLOOP"))
@LI-PCL-PACKAGE@
(in-package :pcl)
(defvar *the-pcl-package* (find-package :pcl))
(defun load-truename (&optional (errorp nil))
(flet () si:*load-pathname* nil))
(in-package "SYSTEM")
(defvar *command-args* nil)
;; if ANY header or license information is printed by the
;; program, then the following License and Enhancement notice
;; must be printed (see License).
(progn
(system:init-system)
(gbc t)
(in-package "USER")
(or lisp::*link-array*
(setq lisp::*link-array*
(make-array (ash 1 11) :element-type 'string-char :fill-pointer 0)))
(si::use-fast-links t)
(let* ((x (append (pathname-directory si::*system-directory*) (list :parent)))
(lsp (append x (list "lsp")))
(cmpnew (append x (list "cmpnew")))
(h (append x (list "h")))
(pcl (append x (list "pcl")))
(gtk (append x (list "gcl-tk"))))
(dolist (d (list lsp cmpnew pcl))
(load (make-pathname :name "sys-proclaim" :type "lisp" :directory d)))
(load (make-pathname :name "tk-package" :type "lsp" :directory gtk))
; (load (make-pathname :name "gcl_cmpmain" :type "lsp" :directory cmpnew))
(load (make-pathname :name "gcl_lfun_list" :type "lsp" :directory cmpnew))
(load (make-pathname :name "gcl_cmpopt" :type "lsp" :directory cmpnew))
(load (make-pathname :name "gcl_auto_new" :type "lsp" :directory lsp))
(gbc t)
(setq compiler::*cmpinclude* "\"cmpinclude.h\"")
(when compiler::*cmpinclude-string*
(with-open-file (st (make-pathname :directory h :name "cmpinclude" :type "h"))
(let
((tem (make-array (file-length st) :element-type 'standard-char
:static t)))
(if (si::fread tem 0 (length tem) st)
(setq compiler::*cmpinclude-string* tem))))))
(setf (symbol-function 'si:clear-compiler-properties)
(symbol-function 'compiler::compiler-clear-compiler-properties))
(setq system::*old-top-level* (symbol-function 'system:top-level))
(defvar si::*lib-directory* (namestring (make-pathname :directory (list :parent))))
(defun system::gcl-top-level (&aux tem)
(si::set-up-top-level)
(if (si::get-command-arg "-compile")
(let (;(system::*quit-tag* (cons nil nil))
;(system::*quit-tags* nil) (system::*break-level* '())
;(system::*break-env* nil) (system::*ihs-base* 1)
;(system::*ihs-top* 1) (system::*current-ihs* 1)
(*break-enable* nil) result)
(setq result
(system:error-set
'(progn
(compile-file
(si::get-command-arg "-compile")
:output-file
(or (si::get-command-arg "-o")
(si::get-command-arg "-compile"))
:o-file
(cond ((equalp
(si::get-command-arg "-o-file")
"nil") nil)
((si::get-command-arg "-o-file" t))
(t t))
:c-file (si::get-command-arg "-c-file" t)
:h-file (si::get-command-arg "-h-file" t)
:data-file (si::get-command-arg "-data-file" t)
:system-p (si::get-command-arg "-system-p" t)))))
(bye (if (or compiler::*error-p* (equal result '(nil))) 1 0))))
(cond ((si::get-command-arg "-batch")
(setq si::*top-level-hook* 'bye))
((si::get-command-arg "-f"))
(t (format t si::*system-banner*)
(format t "Temporary directory for compiler files set to ~a~%" *tmp-dir*)))
(setq si::*ihs-top* 1)
(in-package 'system::user) (incf system::*ihs-top* 2)
(funcall system::*old-top-level*))
(terpri)
(setq si:*inhibit-macro-special* t)
(gbc t) (system:reset-gbc-count)
(defun system:top-level nil (system::gcl-top-level))
(setq compiler::*default-c-file* nil)
(setq compiler::*default-h-file* nil)
(setq compiler::*default-data-file* nil)
(setq compiler::*default-system-p* nil)
(setq compiler::*keep-gaz* nil)
t)
(progn
(unintern 'system)
(unintern 'lisp)
(unintern 'compiler)
(unintern 'user)
(fmakunbound 'si::init-cmp-anon)
(eval-when (load)
(if (fboundp 'get-system-time-zone)
(setf system:*default-time-zone* (get-system-time-zone))
(setf system:*default-time-zone* 6)))
(if (fboundp 'si::user-init) (si::user-init))
(si::set-up-top-level)
(setq si::*gcl-extra-version* @LI-EXTVERS@
si::*gcl-minor-version* @LI-MINVERS@
si::*gcl-major-version* @LI-MAJVERS@)
(setq compiler::*cc* @LI-CC@)
(setq compiler::*ld* @LI-LD@)
(setq compiler::*ld-libs* @LI-LD-LIBS@)
(setq compiler::*opt-three* @LI-OPT-THREE@)
(setq compiler::*opt-two* @LI-OPT-TWO@)
(setq compiler::*init-lsp* @LI-INIT-LSP@)
(defvar si::*system-banner* (si::default-system-banner))
(in-package 'user)
(import 'si::info)
t)
|
