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"))
11
(defvar *the-pcl-package* (find-package :pcl))
12
(defun load-truename (&optional (errorp nil))
13
(flet () si:*load-pathname* nil))
17
(rename-package 'user 'common-lisp-user '(cl-user user))
21
(defvar *command-args* nil)
22
;; if ANY header or license information is printed by the
23
;; program, then the following License and Enhancement notice
24
;; must be printed (see License).
32
;; FIXME integrate this into the stream objects et.al. and/or
34
(defstruct (UNBOUND-SLOT (:constructor %make-UNBOUND-SLOT)))
35
(defstruct ( TWO-WAY-STREAM (:constructor %make-TWO-WAY-STREAM)))
36
(defstruct ( SYNONYM-STREAM (:constructor %make-SYNONYM-STREAM)))
37
(defstruct ( STYLE-WARNING (:constructor %make-STYLE-WARNING)))
38
(defstruct ( STRING-STREAM (:constructor %make-STRING-STREAM)))
39
(defstruct ( STREAM (:constructor %make-STREAM)))
40
(defstruct ( READTABLE (:constructor %make-READTABLE) (:copier %copy-readtable)))
41
(defstruct ( READER-ERROR (:constructor %make-READER-ERROR)))
42
(defstruct ( RANDOM-STATE (:constructor %make-RANDOM-STATE) (:predicate %random-state-p)))
43
(defstruct ( PRINT-NOT-READABLE (:constructor %make-PRINT-NOT-READABLE)))
44
(defstruct (PATHNAME (:constructor %make-PATHNAME)))
45
(defstruct ( PACKAGE (:constructor %make-PACKAGE)))
46
(defstruct ( LOGICAL-PATHNAME (:constructor %make-LOGICAL-PATHNAME)))
47
(defstruct ( HASH-TABLE (:constructor %make-HASH-TABLE) (:predicate %hash-table-p)))
48
(defstruct ( FUNCTION (:constructor %make-FUNCTION)))
49
(defstruct (FLOATING-POINT-INVALID-OPERATION (:constructor %make-FLOATING-POINT-INVALID-OPERATION)))
50
(defstruct ( FLOATING-POINT-INEXACT (:constructor %make-FLOATING-POINT-INEXACT)))
51
(defstruct ( FILE-STREAM (:constructor %make-FILE-STREAM)))
52
(defstruct (ECHO-STREAM (:constructor %make-ECHO-STREAM)))
53
(defstruct ( CONCATENATED-STREAM (:constructor %make-CONCATENATED-STREAM)))
54
(defstruct ( BROADCAST-STREAM (:constructor %make-BROADCAST-STREAM))))
58
(or lisp::*link-array*
59
(setq lisp::*link-array*
60
(make-array (ash 1 11) :element-type 'string-char :fill-pointer 0)))
61
(si::use-fast-links t)
63
(let* ((x (append (pathname-directory si::*system-directory*) (list :parent)))
64
(lsp (append x (list "lsp")))
65
(cmpnew (append x (list "cmpnew")))
66
(h (append x (list "h")))
67
(pcl (append x (list "pcl")))
68
(clcs (append x (list "clcs")))
69
(gtk (append x (list "gcl-tk"))))
70
(dolist (d (list lsp cmpnew pcl clcs))
71
(load (make-pathname :name "sys-proclaim" :type "lisp" :directory d)))
72
(load (make-pathname :name "tk-package" :type "lsp" :directory gtk))
73
(load (make-pathname :name "gcl_cmpmain" :type "lsp" :directory cmpnew))
74
(load (make-pathname :name "gcl_lfun_list" :type "lsp" :directory cmpnew))
75
(load (make-pathname :name "gcl_cmpopt" :type "lsp" :directory cmpnew))
76
(load (make-pathname :name "gcl_auto_new" :type "lsp" :directory lsp))
80
(setq compiler::*cmpinclude* "\"cmpinclude.h\"")
82
(when compiler::*cmpinclude-string*
83
(with-open-file (st (make-pathname :directory h :name "cmpinclude" :type "h"))
85
((tem (make-array (file-length st) :element-type 'standard-char
87
(if (si::fread tem 0 (length tem) st)
88
(setq compiler::*cmpinclude-string* tem))))))
90
(setf (symbol-function 'si:clear-compiler-properties)
91
(symbol-function 'compiler::compiler-clear-compiler-properties))
92
(setq system::*old-top-level* (symbol-function 'system:top-level))
94
(defvar si::*lib-directory* (namestring (make-pathname :directory (list :parent))))
96
(defun system::gcl-top-level (&aux tem)
97
(si::set-up-top-level)
99
(if (si::get-command-arg "-compile")
100
(let (;(system::*quit-tag* (cons nil nil))
101
;(system::*quit-tags* nil) (system::*break-level* '())
102
;(system::*break-env* nil) (system::*ihs-base* 1)
103
;(system::*ihs-top* 1) (system::*current-ihs* 1)
104
(*break-enable* nil) result)
109
(si::get-command-arg "-compile")
111
(or (si::get-command-arg "-o")
112
(si::get-command-arg "-compile"))
115
(si::get-command-arg "-o-file")
117
((si::get-command-arg "-o-file" t))
119
:c-file (si::get-command-arg "-c-file" t)
120
:h-file (si::get-command-arg "-h-file" t)
121
:data-file (si::get-command-arg "-data-file" t)
122
:system-p (si::get-command-arg "-system-p" t)))))
123
(bye (if (or compiler::*error-p* (equal result '(nil))) 1 0))))
124
(cond ((si::get-command-arg "-batch")
125
(setq si::*top-level-hook* 'bye))
126
((si::get-command-arg "-f"))
127
(t (format t si::*system-banner*)))
128
(setq si::*ihs-top* 1)
129
(in-package 'system::user) (incf system::*ihs-top* 2)
130
(funcall system::*old-top-level*))
133
(setq si:*inhibit-macro-special* t)
134
(gbc t) (system:reset-gbc-count)
136
(defun system:top-level nil (system::gcl-top-level))
138
(setq compiler::*default-c-file* nil)
139
(setq compiler::*default-h-file* nil)
140
(setq compiler::*default-data-file* nil)
141
(setq compiler::*default-system-p* nil)
142
(setq compiler::*keep-gaz* nil)
149
CONDITIONS::CHECK-TYPE
151
CONDITIONS::ETYPECASE
152
CONDITIONS::CTYPECASE
157
'(LISP::LAMBDA-BLOCK-CLOSURE
161
LISP::IEEE-FLOATING-POINT
164
LISP::ALLOCATE-CONTIGUOUS-PAGES
171
LISP::MAXIMUM-CONTIGUOUS-PAGES
174
LISP::ALLOCATED-PAGES
193
LISP::ALLOCATED-CONTIGUOUS-PAGES
194
LISP::*EVAL-WHEN-COMPILE*
196
LISP::*IGNORE-MAXIMUM-PAGES*
200
LISP::ALLOCATE-RELOCATABLE-PAGES
203
LISP::MAXIMUM-ALLOCATABLE-PAGES
204
LISP::ALLOCATED-RELOCATABLE-PAGES
209
;anything in "SYSTEM" which should go in "COMMON-LISP"
210
;can be added to shadow-system
211
(setf shadow-system '(system::copy-structure))
213
(do-external-symbols (s "SYSTEM")
214
(when (member s shadow-system)
215
(shadowing-import (list s) "COMMON-LISP")
216
(shadowing-import (list s) "USER")))
219
(do-external-symbols (s "LISP")
220
(if (not(member s lisp_unexport))
222
(import (list s) "COMMON-LISP")
223
(import (list s) "USER")) ))
225
(do-external-symbols (s "PCL")
226
(import (list s) "COMMON-LISP")
227
(import (list s) "USER"))
229
;(shadowing-import (list 'pcl::classp) "SYSTEM")
230
(setf (symbol-function 'si::classp) (symbol-function 'pcl::classp))
231
(setf (symbol-function 'si::class-of) (symbol-function 'pcl::class-of))
232
(setf (symbol-function 'si::class-precedence-list)
233
(symbol-function 'pcl::class-precedence-list))
234
(setf (symbol-function 'si::find-class)
235
(symbol-function 'pcl::find-class))
236
; (setf (symbol-function 'si::find-class-no-error)
237
; (symbol-function 'conditions::find-class-no-error))
239
(do-external-symbols (s "CONDITIONS")
240
(if (member s clcs_shadow)
242
(shadowing-import (list s) "COMMON-LISP")
243
(shadowing-import (list s) "USER"))
245
(import (list s) "COMMON-LISP")
246
(import (list s) "USER"))))
252
(dolist (s '(*compile-file-pathname* *compile-file-truename*
253
*compile-print* *compile-verbose* *load-pathname* *load-print*
254
*load-truename* *print-lines* *print-miser-width*
255
*print-pprint-dispatch* *print-right-margin* *read-eval*
256
lisp::arithmetic-error broadcast-stream-streams cell-error
257
cell-error-name compile compile-file compiler-macro
258
compiler-macro-function complement concatenated-stream-streams
259
condition control-error copy-pprint-dispatch copy-structure count
260
debug define-compiler-macro define-setf-expander define-symbol-macro
261
defpackage describe describe-object division-by-zero dynamic-extent
262
echo-stream-input-stream echo-stream-output-stream
263
ensure-directories-exist fdefinition file-string-length formatter
264
function-lambda-expression get-setf-expansion hash-table-rehash-size
265
hash-table-rehash-threshold interactive-stream-p
266
load-logical-pathname-translations load-time-value
267
logical-pathname-translations make-load-form
268
make-load-form-saving-slots make-method open-stream-p pathname-match-p
269
pprint-dispatch pprint-exit-if-list-exhausted pprint-fill
270
pprint-indent pprint-linear pprint-logical-block pprint-newline
271
pprint-pop pprint-tab pprint-tabular print-not-readable-object
272
print-unreadable-object read-sequence readtable-case row-major-aref
273
set-pprint-dispatch simple-condition-format-control
274
stream-external-format synonym-stream-symbol
275
translate-logical-pathname translate-pathname
276
two-way-stream-input-stream two-way-stream-output-stream
277
unbound-slot-instance
278
upgraded-complex-part-type wild-pathname-p with-compilation-unit
279
with-condition-restarts with-package-iterator with-standard-io-syntax
281
(shadowing-import (list s) "COMMON-LISP"))
283
(use-package "ANSI-LOOP" "COMMON-LISP")
284
(use-package "ANSI-LOOP" "USER")
286
(do-symbols (s "COMMON-LISP")
287
(export (list s) "COMMON-LISP"))
289
(rename-package 'common-lisp 'common-lisp '(cl))
295
(fmakunbound 'si::init-cmp-anon)
297
(makunbound 'clcs_shadow)
298
(makunbound 'lisp_unexport)
299
(makunbound 'shadow-system)
300
(unintern 'clcs_shadow)
301
(unintern 'lisp_unexport)
303
(unintern 'shadow-system)
305
(push :common-lisp *features*)
306
(push :ansi-cl *features*)
309
(if (fboundp 'get-system-time-zone)
310
(setf system:*default-time-zone* (get-system-time-zone))
311
(setf system:*default-time-zone* 6)))
313
(if (fboundp 'si::user-init) (si::user-init))
314
(si::set-up-top-level)
316
(setq si::*gcl-extra-version* @LI-EXTVERS@
317
si::*gcl-minor-version* @LI-MINVERS@
318
si::*gcl-major-version* @LI-MAJVERS@)
319
(setq compiler::*cc* @LI-CC@)
320
(setq compiler::*ld* @LI-LD@)
321
(setq compiler::*ld-libs* @LI-LD-LIBS@)
322
(setq compiler::*opt-three* @LI-OPT-THREE@)
323
(setq compiler::*opt-two* @LI-OPT-TWO@)
324
(setq compiler::*init-lsp* @LI-INIT-LSP@)
326
(defvar si::*system-banner* (si::default-system-banner))
added
removed
unixport/init_ansi_gcl.lsp.in
