source: trunk/source/level-1/l1-boot-2.lisp

Last change on this file was 16685, checked in by rme, 4 years ago

Update copyright/license headers in files.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 15.6 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;; Copyright 1994-2009 Clozure Associates
4;;;
5;;; Licensed under the Apache License, Version 2.0 (the "License");
6;;; you may not use this file except in compliance with the License.
7;;; You may obtain a copy of the License at
8;;;
9;;;     http://www.apache.org/licenses/LICENSE-2.0
10;;;
11;;; Unless required by applicable law or agreed to in writing, software
12;;; distributed under the License is distributed on an "AS IS" BASIS,
13;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
14;;; See the License for the specific language governing permissions and
15;;; limitations under the License.
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                       (*loading-toplevel-location* *loading-toplevel-location*))
31                  (%fasload ,namestring))))
32           (bin-load (name)
33             (let* ((namestring
34                     (concatenate 'simple-base-string
35                                  "./bin/"
36                                  (string name)
37                                  (namestring (backend-target-fasl-pathname
38                                               *target-backend*)))))
39               `(let* ((*loading-file-source-file* *loading-file-source-file*)
40                       (*loading-toplevel-location* *loading-toplevel-location*))
41                  (%fasload ,namestring)))))
42
43
44(catch :toplevel
45    #+ppc-target
46    (l1-load "ppc-error-signal")
47    #+x86-target
48    (l1-load "x86-error-signal")
49    #+arm-target
50    (l1-load "arm-error-signal")
51    (l1-load "l1-error-signal")
52    (l1-load "l1-sockets")
53    (setq *LEVEL-1-LOADED* t))
54
55#+ppc-target
56(defun altivec-available-p ()
57  "Return non-NIL if AltiVec is available."
58  (not (eql (%get-kernel-global 'ppc::altivec-present) 0)))
59
60#+ppc-target
61(defloadvar *altivec-available* (altivec-available-p)
62  "This variable is intitialized each time a Clozure CL session starts based
63on information provided by the lisp kernel. Its value is true if AltiVec is
64present and false otherwise. This variable shouldn't be set by user code.")
65
66       
67(defstatic *auto-flush-streams* ())
68(def-ccl-pointers *auto-flush-streams* () (setq *auto-flush-streams* nil))
69(defstatic *auto-flush-streams-lock* (make-lock))
70
71
72(defvar *batch-flag* (not (eql (%get-kernel-global 'batch-flag) 0)))
73(defloadvar *quiet-flag* nil)
74(defvar *terminal-input* ())
75(defvar *terminal-output* ())
76(defvar *stdin* ())
77(defvar *stdout* ())
78(defvar *stderr* ())
79
80
81(defun set-basic-stream-prototype (class)
82  (when (subtypep class 'basic-stream)
83    (setf (%class.prototype class) (or (%class.prototype class)
84                                       (allocate-basic-stream class)))
85    (dolist (subclass (class-direct-subclasses class))
86      (set-basic-stream-prototype subclass))))
87
88(set-basic-stream-prototype (find-class 'basic-stream))
89
90
91;;; The hard parts here have to do with setting up *TERMINAL-IO*.
92;;; Note that opening /dev/tty can fail, and that failure would
93;;; be reported as a negative return value from FD-OPEN.
94;;; It's pretty important that nothing signals an error here,
95;;; since there may not be any valid streams to write an error
96;;; message to.
97
98(defglobal *interactive-streams-initialized* nil)
99
100#+windows-target
101(progn
102
103
104(defun validate-standard-io-handles ()
105  (let* ((in (#_GetStdHandle #$STD_INPUT_HANDLE))
106         (out (#_GetStdHandle #$STD_OUTPUT_HANDLE)))
107    (when (or (%null-ptr-p in)
108              (%null-ptr-p out))
109      (let* ((nulldevice (open-null-device)))
110        (when nulldevice
111          (when (%null-ptr-p in)
112            (#_SetStdHandle #$STD_INPUT_HANDLE nulldevice))
113          (when (%null-ptr-p out)
114            (#_SetStdHandle #$STD_OUTPUT_HANDLE nulldevice)
115            (ff-call (ccl::%kernel-import target::kernel-import-open-debug-output)
116                     :int (%ptr-to-int nulldevice)
117                     :int)))))))
118)
119
120(defun initialize-interactive-streams ()
121  (let* ((encoding (lookup-character-encoding *terminal-character-encoding-name*))
122         (encoding-name (if encoding (character-encoding-name encoding))))
123    #+windows-target (validate-standard-io-handles)
124    (setq *stdin* (let* ((infd #-windows-target 0
125                               #+windows-target (%ptr-to-int
126                                                 (#_GetStdHandle #$STD_INPUT_HANDLE))))
127                               (make-fd-stream infd
128                                  :basic t
129                                  :sharing :lock
130                                  :direction :input
131                                  :interactive (or (not *batch-flag*)
132                                                   (< (fd-lseek infd 0 #$SEEK_CUR)                                                     
133                                                      0))
134                                  :encoding encoding-name
135                                  #+windows-target :line-termination #+windows-target :cp/m)))
136    (setq *stdout* (make-fd-stream #-windows-target 1
137                                   #+windows-target (%ptr-to-int
138                                                     (#_GetStdHandle #$STD_OUTPUT_HANDLE))
139                                   :basic t :direction :output :sharing :lock :encoding encoding-name #+windows-target :line-termination #+windows-target :msdos))
140    (setq *stderr* (make-fd-stream #-windows-target 2
141                                   #+windows-target (%ptr-to-int
142                                                     (#_GetStdHandle #$STD_ERROR_HANDLE))
143                                   :basic t :direction :output :sharing :lock :encoding encoding-name #+windows-target :line-termination #+windows-target :crlf))
144    (add-auto-flush-stream *stdout*)
145    (add-auto-flush-stream *stderr*)
146    (if *batch-flag*
147      (let* ((tty-fd
148              #-windows-target
149               (let* ((fd (fd-open "/dev/tty" #$O_RDWR)))
150                 (if (>= fd 0) fd)))
151             (can-use-tty #-windows-target (and tty-fd (eql (tcgetpgrp tty-fd) (getpid)))))
152        (if can-use-tty
153          (progn
154            (setq
155             *terminal-input* (make-fd-stream tty-fd
156                                              :basic t
157                                              :direction :input
158                                              :interactive t
159                                              :sharing :lock
160                                              :encoding encoding-name)
161             *terminal-output* (make-fd-stream tty-fd :basic t :direction :output :sharing :lock :encoding encoding-name)
162             *terminal-io* (make-echoing-two-way-stream
163                            *terminal-input* *terminal-output*))
164            (add-auto-flush-stream *terminal-output*))
165          (progn
166            (when tty-fd (fd-close tty-fd))
167            (setq *terminal-input* *stdin*
168                  *terminal-output* *stdout*
169                  *terminal-io* (make-two-way-stream
170                                 *terminal-input* *terminal-output*))))
171        (setq *standard-input* *stdin*
172              *standard-output* *stdout*))
173      (progn
174        (setq *terminal-input* *stdin*
175              *terminal-output* *stdout*
176              *terminal-io* (make-echoing-two-way-stream
177                             *terminal-input* *terminal-output*))
178        (setq *standard-input* (make-synonym-stream '*terminal-io*)
179              *standard-output* (make-synonym-stream '*terminal-io*))))
180    (setq *error-output* (if (or *batch-flag*
181                                 (not (same-fd-p (stream-device *stderr* :output)
182                                                 (stream-device *stdout* :output))))
183                           (make-synonym-stream '*stderr*)
184                           (make-synonym-stream '*terminal-io*)))
185    (setq *query-io* (make-synonym-stream '*terminal-io*))
186    (setq *debug-io* *query-io*)
187    (setq *trace-output* *standard-output*)
188    (push *stdout* *auto-flush-streams*)
189    (setf (input-stream-shared-resource *terminal-input*)
190          (make-shared-resource "Shared Terminal Input")))
191  (setq *interactive-streams-initialized* t))
192
193(initialize-interactive-streams)
194
195(def-standard-initial-binding *standard-input*)
196(def-standard-initial-binding *standard-output*)
197(def-standard-initial-binding *error-output*)
198(def-standard-initial-binding *trace-output*)
199(def-standard-initial-binding *debug-io*)
200(def-standard-initial-binding *query-io*)
201
202;;; Things bound by WITH-STANDARD-IO-SYNTAX (and not otherwise thread-local)
203(def-standard-initial-binding *read-base*)
204(def-standard-initial-binding *read-default-float-format*)
205(def-standard-initial-binding *read-eval*) 
206(def-standard-initial-binding *read-suppress*)
207
208
209
210(defun set-terminal-encoding (encoding-name)
211  #+windows-target (when (atom encoding-name)
212                     (setq encoding-name `(:character-encoding ,encoding-name
213                                           :line-termination :crlf)))
214  (let* ((exformat (normalize-external-format t encoding-name)))
215    (setf (stream-external-format *stdin*) exformat
216          (stream-external-format *stdout*) exformat
217          (stream-external-format *stderr*) exformat
218          (stream-external-format *terminal-input*) exformat
219          (stream-external-format *terminal-output*) exformat))
220  encoding-name)
221
222(catch :toplevel
223    (macrolet ((l1-load-provide (module path)
224                 `(let* ((*package* *package*))
225                   (l1-load ,path)
226                   (provide ,module)))
227               (bin-load-provide (module path)
228                 `(let* ((*package* *package*))
229                   (bin-load ,path)
230                   (provide ,module))))
231      (bin-load-provide "SORT" "sort")
232      (bin-load-provide "NUMBERS" "numbers")
233     
234      (bin-load-provide "SUBPRIMS" "subprims")
235      #+ppc32-target
236      (bin-load-provide "PPC32-ARCH" "ppc32-arch") 
237      #+ppc64-target
238      (bin-load-provide "PPC64-ARCH" "ppc64-arch")
239      #+x86-target
240      (bin-load-provide "X8632-ARCH" "x8632-arch")
241      #+x86-target
242      (bin-load-provide "X8664-ARCH" "x8664-arch")
243      #+arm-target
244      (bin-load-provide "ARM-ARCH" "arm-arch")
245      (bin-load-provide "VREG" "vreg")
246     
247      #+ppc-target
248      (bin-load-provide "PPC-ASM" "ppc-asm")
249      #+arm-target
250      (bin-load-provide "ARM-ASM" "arm-asm")
251     
252      (bin-load-provide "VINSN" "vinsn")
253      (bin-load-provide "REG" "reg")
254     
255      #+ppc-target
256      (bin-load-provide "PPC-LAP" "ppc-lap")
257      #+arm-target
258      (bin-load-provide "ARM-LAP" "arm-lap")
259      (bin-load-provide "BACKEND" "backend")
260      (bin-load-provide "NX2" "nx2")
261     
262      #+ppc-target
263      (provide "PPC2")                  ; Lie, load the module manually
264
265      #+x86-target
266      (provide "X862")
267
268      #+arm-target
269      (provide "ARM2") 
270      (bin-load-provide "ACODE-REWRITE" "acode-rewrite")
271     
272      (l1-load-provide "NX" "nx")
273     
274      #+ppc-target
275      (bin-load "ppc2")
276
277      #+x86-target
278      (bin-load "x862")
279
280      #+arm-target
281      (bin-load "arm2")
282     
283      (bin-load-provide "LEVEL-2" "level-2")
284      (bin-load-provide "MACROS" "macros")
285      (bin-load-provide "SETF" "setf")
286      (bin-load-provide "SETF-RUNTIME" "setf-runtime")
287      (bin-load-provide "FORMAT" "format")
288      (bin-load-provide "STREAMS" "streams")
289      (bin-load-provide "OPTIMIZERS" "optimizers")     
290      (bin-load-provide "DEFSTRUCT-MACROS" "defstruct-macros")
291      (bin-load-provide "DEFSTRUCT-LDS" "defstruct-lds")
292      (bin-load-provide "NFCOMP" "nfcomp")
293      (bin-load-provide "BACKQUOTE" "backquote")
294      (bin-load-provide "BACKTRACE-LDS" "backtrace-lds")
295      (bin-load-provide "BACKTRACE" "backtrace")
296      (bin-load-provide "READ" "read")
297      (bin-load-provide "ARRAYS-FRY" "arrays-fry")
298      (bin-load-provide "APROPOS" "apropos")
299      (bin-load-provide "SOURCE-FILES" "source-files")
300     
301      #+ppc-target
302      (progn
303        (bin-load-provide "PPC-DISASSEMBLE" "ppc-disassemble")
304        (bin-load-provide "PPC-LAPMACROS" "ppc-lapmacros"))
305
306      #+x86-target
307      (progn
308        (bin-load-provide "X86-DISASSEMBLE" "x86-disassemble")
309        (bin-load-provide "X86-LAPMACROS" "x86-lapmacros")
310        (bin-load "x86-watch"))
311
312      #+arm-target
313      (progn
314        (bin-load-provide "ARM-DISASSEMBLE" "arm-disassemble")
315        (bin-load-provide "ARM-LAPMACROS" "arm-lapmacros"))
316
317      (bin-load-provide "FOREIGN-TYPES" "foreign-types")
318      (install-standard-foreign-types *host-ftd*)
319     
320      #+(and ppc32-target linux-target)
321      (bin-load-provide "FFI-LINUXPPC32" "ffi-linuxppc32")
322      #+(and ppc32-target darwin-target)
323      (bin-load-provide "FFI-DARWINPPC32" "ffi-darwinppc32")
324      #+(and ppc64-target darwin-target)
325      (bin-load-provide "FFI-DARWINPPC64" "ffi-darwinppc64")
326      #+(and ppc64-target linux-target)
327      (bin-load-provide "FFI-LINUXPPC64" "ffi-linuxppc64")
328      #+(and x8632-target darwin-target)
329      (bin-load-provide "FFI-DARWINX8632" "ffi-darwinx8632")
330      #+(and x8664-target linux-target) 
331      (bin-load-provide "FFI-LINUXX8664" "ffi-linuxx8664")
332      #+(and x8664-target darwin-target) 
333      (bin-load-provide "FFI-DARWINX8664" "ffi-darwinx8664")
334      #+(and x8664-target freebsd-target) 
335      (bin-load-provide "FFI-FREEBSDX8664" "ffi-freebsdx8664")
336      #+(and x8664-target solaris-target)
337      (bin-load-provide "FFI-SOLARISX8664" "ffi-solarisx8664")
338      #+win64-target
339      (bin-load-provide "FFI-WIN64" "ffi-win64")
340      #+linuxx8632-target
341      (bin-load-provide "FFI-LINUXX8632" "ffi-linuxx8632")
342      #+win32-target
343      (bin-load-provide "FFI-WIN32" "ffi-win32")
344      #+solarisx8632-target
345      (bin-load-provide "FFI-SOLARISX8632" "ffi-solarisx8632")
346      #+freebsdx8632-target
347      (bin-load-provide "FFI-FREEBSDX8632" "ffi-freebsdx8632")
348      #+(and arm-target linux-target (not android-target))
349      (bin-load-provide "FFI-LINUXARM" "ffi-linuxarm")
350      #+(and arm-target android-target)
351      (bin-load-provide "FFI-ANDROIDARM" "ffi-androidarm")
352      #+(and arm-target darwin-target)
353      (bin-load-provide "FFI-DARWINARM" "ffi-darwinarm")
354
355
356      ;; Knock wood: all standard reader macros and no non-standard
357      ;; reader macros are defined at this point.
358      (setq *readtable* (copy-readtable *readtable*))
359
360      (bin-load-provide "DB-IO" "db-io")
361
362      (canonicalize-foreign-type-ordinals *host-ftd*)
363     
364      (bin-load-provide "CASE-ERROR" "case-error")
365      (bin-load-provide "ENCAPSULATE" "encapsulate")
366      (bin-load-provide "METHOD-COMBINATION" "method-combination")
367      (bin-load-provide "MISC" "misc")
368      (bin-load-provide "PPRINT" "pprint")
369      (bin-load-provide "DUMPLISP" "dumplisp")
370      (bin-load-provide "PATHNAMES" "pathnames")
371      (bin-load-provide "TIME" "time")
372      (bin-load-provide "COMPILE-CCL" "compile-ccl")
373      (bin-load-provide "ARGLIST" "arglist")
374      (bin-load-provide "EDIT-CALLERS" "edit-callers")
375      (bin-load-provide "DESCRIBE" "describe")
376      (bin-load-provide "SWINK" "swink")
377      (bin-load-provide "COVER" "cover")
378      (bin-load-provide "LEAKS" "leaks")
379      (bin-load-provide "CORE-FILES" "core-files")
380      (bin-load-provide "DOMINANCE" "dominance")
381      (bin-load-provide "SWANK-LOADER" "swank-loader")
382      (bin-load-provide "REMOTE-LISP" "remote-lisp")
383      (bin-load-provide "MCL-COMPAT" "mcl-compat")
384      (require "LOOP")
385      (bin-load-provide "CCL-EXPORT-SYMS" "ccl-export-syms")
386      (l1-load-provide "VERSION" "version")
387      (require "JP-ENCODE")
388      (require "CN-ENCODE")
389      (require "LISPEQU") ; Shouldn't need this at load time ...
390      (require "SOCKETS")
391      )
392    (setq *%fasload-verbose* nil)
393    )
394)
395
396
397
398
399
400
Note: See TracBrowser for help on using the repository browser.