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

Last change on this file since 15791 was 15791, checked in by gb, 7 years ago

INITIALIZE-INTERACTIVE-STREAMS: *STDIN* is non-interactive iff *BATCH-FLAG*
and fd 0 (or Windows equivalent) is seekable.
See <http://clozure.com/pipermail/openmcl-devel/2013-March/014210.html>

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