1 | ;;;-*- Mode: Lisp; Package: CCL -*- |
---|
2 | ;;; |
---|
3 | ;;; Copyright (C) 1994-2001 Digitool, Inc |
---|
4 | ;;; This file is part of OpenMCL. |
---|
5 | ;;; |
---|
6 | ;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public |
---|
7 | ;;; License , known as the LLGPL and distributed with OpenMCL as the |
---|
8 | ;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, |
---|
9 | ;;; which is distributed with OpenMCL as the file "LGPL". Where these |
---|
10 | ;;; conflict, the preamble takes precedence. |
---|
11 | ;;; |
---|
12 | ;;; OpenMCL is referenced in the preamble as the "LIBRARY." |
---|
13 | ;;; |
---|
14 | ;;; The LLGPL is also available online at |
---|
15 | ;;; http://opensource.franz.com/preamble.html |
---|
16 | |
---|
17 | ;; l1-boot-2.lisp |
---|
18 | ;; Second part of l1-boot |
---|
19 | |
---|
20 | (in-package "CCL") |
---|
21 | |
---|
22 | (macrolet ((l1-load (name) |
---|
23 | (let* ((namestring |
---|
24 | (concatenate 'simple-base-string |
---|
25 | "./l1-fasls/" |
---|
26 | (string name) |
---|
27 | (namestring (backend-target-fasl-pathname |
---|
28 | *target-backend*))))) |
---|
29 | `(let* ((*loading-file-source-file* *loading-file-source-file*)) |
---|
30 | (%fasload ,namestring)))) |
---|
31 | (bin-load (name) |
---|
32 | (let* ((namestring |
---|
33 | (concatenate 'simple-base-string |
---|
34 | "./bin/" |
---|
35 | (string name) |
---|
36 | (namestring (backend-target-fasl-pathname |
---|
37 | *target-backend*))))) |
---|
38 | `(let* ((*loading-file-source-file* *loading-file-source-file*)) |
---|
39 | (%fasload ,namestring))))) |
---|
40 | |
---|
41 | |
---|
42 | (catch :toplevel |
---|
43 | #+ppc-target |
---|
44 | (l1-load "ppc-error-signal") |
---|
45 | #+x86-target |
---|
46 | (l1-load "x86-error-signal") |
---|
47 | (l1-load "l1-error-signal") |
---|
48 | (l1-load "l1-sockets") |
---|
49 | (setq *LEVEL-1-LOADED* t)) |
---|
50 | |
---|
51 | #+ppc-target |
---|
52 | (defun altivec-available-p () |
---|
53 | "Return non-NIL if AltiVec is available." |
---|
54 | (not (eql (%get-kernel-global 'ppc::altivec-present) 0))) |
---|
55 | |
---|
56 | #+ppc-target |
---|
57 | (defloadvar *altivec-available* (altivec-available-p) |
---|
58 | "This variable is intitialized each time an OpenMCL session starts based |
---|
59 | on information provided by the lisp kernel. Its value is true if AltiVec is |
---|
60 | present and false otherwise. This variable shouldn't be set by user code.") |
---|
61 | |
---|
62 | |
---|
63 | (defstatic *auto-flush-streams* ()) |
---|
64 | (def-ccl-pointers *auto-flush-streams* () (setq *auto-flush-streams* nil)) |
---|
65 | (defstatic *auto-flush-streams-lock* (make-lock)) |
---|
66 | |
---|
67 | |
---|
68 | (defloadvar *batch-flag* (not (eql (%get-kernel-global 'batch-flag) 0))) |
---|
69 | (defloadvar *quiet-flag* nil) |
---|
70 | (defvar *terminal-input* ()) |
---|
71 | (defvar *terminal-output* ()) |
---|
72 | (defvar *stdin* ()) |
---|
73 | (defvar *stdout* ()) |
---|
74 | (defvar *stderr* ()) |
---|
75 | |
---|
76 | |
---|
77 | (defun set-basic-stream-prototype (class) |
---|
78 | (when (subtypep class 'basic-stream) |
---|
79 | (setf (%class.prototype class) (or (%class.prototype class) |
---|
80 | (allocate-basic-stream class))) |
---|
81 | (dolist (subclass (class-direct-subclasses class)) |
---|
82 | (set-basic-stream-prototype subclass)))) |
---|
83 | |
---|
84 | (set-basic-stream-prototype (find-class 'basic-stream)) |
---|
85 | |
---|
86 | |
---|
87 | ;;; The hard parts here have to do with setting up *TERMINAL-IO*. |
---|
88 | ;;; Note that opening /dev/tty can fail, and that failure would |
---|
89 | ;;; be reported as a negative return value from FD-OPEN. |
---|
90 | ;;; It's pretty important that nothing signals an error here, |
---|
91 | ;;; since there may not be any valid streams to write an error |
---|
92 | ;;; message to. |
---|
93 | |
---|
94 | (defloadvar *interactive-streams-initialized* nil) |
---|
95 | |
---|
96 | (defun initialize-interactive-streams () |
---|
97 | (let* ((encoding (lookup-character-encoding *terminal-character-encoding-name*)) |
---|
98 | (encoding-name (if encoding (character-encoding-name encoding)))) |
---|
99 | (setq *stdin* (make-fd-stream 0 |
---|
100 | :basic t |
---|
101 | :sharing :lock |
---|
102 | :direction :input |
---|
103 | :interactive (not *batch-flag*) |
---|
104 | :encoding encoding-name)) |
---|
105 | (setq *stdout* (make-fd-stream 1 :basic t :direction :output :sharing :lock :encoding encoding-name)) |
---|
106 | |
---|
107 | (setq *stderr* (make-fd-stream 2 :basic t :direction :output :sharing :lock :encoding encoding-name)) |
---|
108 | (if *batch-flag* |
---|
109 | (let* ((tty-fd (let* ((fd (fd-open "/dev/tty" #$O_RDWR))) |
---|
110 | (if (>= fd 0) fd))) |
---|
111 | (can-use-tty (and tty-fd (eql (tcgetpgrp tty-fd) (getpid))))) |
---|
112 | (if can-use-tty |
---|
113 | (setq |
---|
114 | *terminal-input* (make-fd-stream tty-fd |
---|
115 | :basic t |
---|
116 | :direction :input |
---|
117 | :interactive t |
---|
118 | :sharing :lock |
---|
119 | :encoding encoding-name) |
---|
120 | *terminal-output* (make-fd-stream tty-fd :basic t :direction :output :sharing :lock :encoding encoding-name) |
---|
121 | *terminal-io* (make-echoing-two-way-stream |
---|
122 | *terminal-input* *terminal-output*)) |
---|
123 | (progn |
---|
124 | (when tty-fd (fd-close tty-fd)) |
---|
125 | (setq *terminal-input* *stdin* |
---|
126 | *terminal-output* *stdout* |
---|
127 | *terminal-io* (make-two-way-stream |
---|
128 | *terminal-input* *terminal-output*)))) |
---|
129 | (setq *standard-input* *stdin* |
---|
130 | *standard-output* *stdout*)) |
---|
131 | (progn |
---|
132 | (setq *terminal-input* *stdin* |
---|
133 | *terminal-output* *stdout* |
---|
134 | *terminal-io* (make-echoing-two-way-stream |
---|
135 | *terminal-input* *terminal-output*)) |
---|
136 | (setq *standard-input* (make-synonym-stream '*terminal-io*) |
---|
137 | *standard-output* (make-synonym-stream '*terminal-io*)))) |
---|
138 | (setq *error-output* (if *batch-flag* |
---|
139 | (make-synonym-stream '*stderr*) |
---|
140 | (make-synonym-stream '*terminal-io*))) |
---|
141 | (setq *query-io* (make-synonym-stream '*terminal-io*)) |
---|
142 | (setq *debug-io* *query-io*) |
---|
143 | (setq *trace-output* *standard-output*) |
---|
144 | (push *stdout* *auto-flush-streams*) |
---|
145 | (setf (input-stream-shared-resource *terminal-input*) |
---|
146 | (make-shared-resource "Shared Terminal Input"))) |
---|
147 | (setq *interactive-streams-initialized* t)) |
---|
148 | |
---|
149 | (initialize-interactive-streams) |
---|
150 | |
---|
151 | (def-standard-initial-binding *standard-input*) |
---|
152 | (def-standard-initial-binding *standard-output*) |
---|
153 | (def-standard-initial-binding *error-output*) |
---|
154 | (def-standard-initial-binding *trace-output*) |
---|
155 | (def-standard-initial-binding *debug-io*) |
---|
156 | (def-standard-initial-binding *query-io*) |
---|
157 | |
---|
158 | |
---|
159 | |
---|
160 | |
---|
161 | (catch :toplevel |
---|
162 | (macrolet ((l1-load-provide (module path) |
---|
163 | `(let* ((*package* *package*)) |
---|
164 | (l1-load ,path) |
---|
165 | (provide ,module))) |
---|
166 | (bin-load-provide (module path) |
---|
167 | `(let* ((*package* *package*)) |
---|
168 | (bin-load ,path) |
---|
169 | (provide ,module)))) |
---|
170 | (bin-load-provide "SORT" "sort") |
---|
171 | (bin-load-provide "NUMBERS" "numbers") |
---|
172 | |
---|
173 | (bin-load-provide "SUBPRIMS" "subprims") |
---|
174 | #+ppc32-target |
---|
175 | (bin-load-provide "PPC32-ARCH" "ppc32-arch") |
---|
176 | #+ppc64-target |
---|
177 | (bin-load-provide "PPC64-ARCH" "ppc64-arch") |
---|
178 | #+x8664-target |
---|
179 | (bin-load-provide "X8664-ARCH" "x8664-arch") |
---|
180 | (bin-load-provide "VREG" "vreg") |
---|
181 | |
---|
182 | #+ppc-target |
---|
183 | (bin-load-provide "PPC-ASM" "ppc-asm") |
---|
184 | |
---|
185 | (bin-load-provide "VINSN" "vinsn") |
---|
186 | (bin-load-provide "REG" "reg") |
---|
187 | |
---|
188 | #+ppc-target |
---|
189 | (bin-load-provide "PPC-LAP" "ppc-lap") |
---|
190 | (bin-load-provide "BACKEND" "backend") |
---|
191 | |
---|
192 | #+ppc-target |
---|
193 | (provide "PPC2") ; Lie, load the module manually |
---|
194 | |
---|
195 | #+x86-target |
---|
196 | (provide "X862") |
---|
197 | |
---|
198 | (l1-load-provide "NX" "nx") |
---|
199 | |
---|
200 | #+ppc-target |
---|
201 | (bin-load "ppc2") |
---|
202 | |
---|
203 | #+x86-target |
---|
204 | (bin-load "x862") |
---|
205 | |
---|
206 | (bin-load-provide "LEVEL-2" "level-2") |
---|
207 | (bin-load-provide "MACROS" "macros") |
---|
208 | (bin-load-provide "SETF" "setf") |
---|
209 | (bin-load-provide "SETF-RUNTIME" "setf-runtime") |
---|
210 | (bin-load-provide "FORMAT" "format") |
---|
211 | (bin-load-provide "STREAMS" "streams") |
---|
212 | (bin-load-provide "OPTIMIZERS" "optimizers") |
---|
213 | (bin-load-provide "DEFSTRUCT-MACROS" "defstruct-macros") |
---|
214 | (bin-load-provide "DEFSTRUCT-LDS" "defstruct-lds") |
---|
215 | (bin-load-provide "NFCOMP" "nfcomp") |
---|
216 | (bin-load-provide "BACKQUOTE" "backquote") |
---|
217 | (bin-load-provide "BACKTRACE-LDS" "backtrace-lds") |
---|
218 | (bin-load-provide "BACKTRACE" "backtrace") |
---|
219 | (bin-load-provide "READ" "read") |
---|
220 | (bin-load-provide "ARRAYS-FRY" "arrays-fry") |
---|
221 | (bin-load-provide "APROPOS" "apropos") |
---|
222 | |
---|
223 | #+ppc-target |
---|
224 | (progn |
---|
225 | (bin-load-provide "PPC-DISASSEMBLE" "ppc-disassemble") |
---|
226 | (bin-load-provide "PPC-LAPMACROS" "ppc-lapmacros")) |
---|
227 | |
---|
228 | #+x86-target |
---|
229 | (progn |
---|
230 | (bin-load-provide "X86-DISASSEMBLE" "x86-disassemble") |
---|
231 | (bin-load-provide "X86-LAPMACROS" "x86-lapmacros")) |
---|
232 | |
---|
233 | |
---|
234 | (bin-load-provide "FOREIGN-TYPES" "foreign-types") |
---|
235 | (install-standard-foreign-types *host-ftd*) |
---|
236 | |
---|
237 | #+(and ppc32-target linux-target) |
---|
238 | (bin-load-provide "FFI-LINUXPPC32" "ffi-linuxppc32") |
---|
239 | #+(and ppc32-target darwin-target) |
---|
240 | (bin-load-provide "FFI-DARWINPPC32" "ffi-darwinppc32") |
---|
241 | #+(and ppc64-target darwin-target) |
---|
242 | (bin-load-provide "FFI-DARWINPPC64" "ffi-darwinppc64") |
---|
243 | #+(and ppc64-target linux-target) |
---|
244 | (bin-load-provide "FFI-LINUXPPC64" "ffi-linuxppc64") |
---|
245 | #+(and x8664-target linux-target) |
---|
246 | (bin-load-provide "FFI-LINUXX8664" "ffi-linuxx8664") |
---|
247 | #+(and x8664-target darwin-target) |
---|
248 | (bin-load-provide "FFI-DARWINX8664" "ffi-darwinx8664") |
---|
249 | #+(and x8664-target freebsd-target) |
---|
250 | (bin-load-provide "FFI-FREEBSDX8664" "ffi-freebsdx8664") |
---|
251 | |
---|
252 | (bin-load-provide "DB-IO" "db-io") |
---|
253 | |
---|
254 | (canonicalize-foreign-type-ordinals *host-ftd*) |
---|
255 | |
---|
256 | (bin-load-provide "CASE-ERROR" "case-error") |
---|
257 | (bin-load-provide "ENCAPSULATE" "encapsulate") |
---|
258 | (bin-load-provide "METHOD-COMBINATION" "method-combination") |
---|
259 | (bin-load-provide "MISC" "misc") |
---|
260 | (bin-load-provide "PPRINT" "pprint") |
---|
261 | (bin-load-provide "DUMPLISP" "dumplisp") |
---|
262 | (bin-load-provide "PATHNAMES" "pathnames") |
---|
263 | (bin-load-provide "TIME" "time") |
---|
264 | (bin-load-provide "COMPILE-CCL" "compile-ccl") |
---|
265 | (bin-load-provide "ARGLIST" "arglist") |
---|
266 | (bin-load-provide "EDIT-CALLERS" "edit-callers") |
---|
267 | (bin-load-provide "DESCRIBE" "describe") |
---|
268 | (bin-load-provide "SOURCE-FILES" "source-files") |
---|
269 | (bin-load-provide "MCL-COMPAT" "mcl-compat") |
---|
270 | (require "LOOP") |
---|
271 | (bin-load-provide "CCL-EXPORT-SYMS" "ccl-export-syms") |
---|
272 | (l1-load-provide "VERSION" "version") |
---|
273 | (require "LISPEQU") ; Shouldn't need this at load time ... |
---|
274 | ) |
---|
275 | (setq *%fasload-verbose* nil) |
---|
276 | ) |
---|
277 | ) |
---|
278 | |
---|
279 | |
---|
280 | |
---|
281 | |
---|
282 | |
---|
283 | |
---|