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

Last change on this file since 15109 was 15108, checked in by gb, 8 years ago

On Windows, if one or both of the standard input/output handles
is a null pointer (as can happen in a GUI application), redirect
standard I/O to the Windows null device.

(Untested, since we're currently keeping .xib files instead of
.nibs in svn, and have no way of producing .nibs natively on Windows).

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