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

Last change on this file since 15265 was 15230, checked in by gb, 8 years ago

(SAME-FD-P a b) returns true if it can tell that file descriptors
(file handles on Windows) a and b refer to the same underlying file
(socket, pipe, tty.)

Make *ERROR-OUTPUT* a synonym to CCL::*STDERR* if *batch-flag* or if
file descriptors 1 and 2 (or the Windows equivalents) don't refer
to the same file (handy for those who run interactively with whatever
line noise is required to redirect fd 2 ...)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 15.4 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* (make-fd-stream #-windows-target 0
126                                  #+windows-target (%ptr-to-int
127                                                    (#_GetStdHandle #$STD_INPUT_HANDLE))
128                                  :basic t
129                                  :sharing :lock
130                                  :direction :input
131                                  :interactive (not *batch-flag*)
132                                  :encoding encoding-name
133                                  #+windows-target :line-termination #+windows-target :cp/m))
134    (setq *stdout* (make-fd-stream #-windows-target 1
135                                   #+windows-target (%ptr-to-int
136                                                     (#_GetStdHandle #$STD_OUTPUT_HANDLE))
137                                   :basic t :direction :output :sharing :lock :encoding encoding-name #+windows-target :line-termination #+windows-target :msdos))
138    (setq *stderr* (make-fd-stream #-windows-target 2
139                                   #+windows-target (%ptr-to-int
140                                                     (#_GetStdHandle #$STD_ERROR_HANDLE))
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*)
144    (if *batch-flag*
145      (let* ((tty-fd
146              #-windows-target
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)))))
150        (if can-use-tty
151          (progn
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
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 (or *batch-flag*
179                                 (not (same-fd-p (stream-device *stderr* :output)
180                                                 (stream-device *stdout* :output))))
181                           (make-synonym-stream '*stderr*)
182                           (make-synonym-stream '*terminal-io*)))
183    (setq *query-io* (make-synonym-stream '*terminal-io*))
184    (setq *debug-io* *query-io*)
185    (setq *trace-output* *standard-output*)
186    (push *stdout* *auto-flush-streams*)
187    (setf (input-stream-shared-resource *terminal-input*)
188          (make-shared-resource "Shared Terminal Input")))
189  (setq *interactive-streams-initialized* t))
190
191(initialize-interactive-streams)
192
193(def-standard-initial-binding *standard-input*)
194(def-standard-initial-binding *standard-output*)
195(def-standard-initial-binding *error-output*)
196(def-standard-initial-binding *trace-output*)
197(def-standard-initial-binding *debug-io*)
198(def-standard-initial-binding *query-io*)
199
200;;; Things bound by WITH-STANDARD-IO-SYNTAX (and not otherwise thread-local)
201(def-standard-initial-binding *read-base*)
202(def-standard-initial-binding *read-default-float-format*)
203(def-standard-initial-binding *read-eval*) 
204(def-standard-initial-binding *read-suppress*)
205
206
207
208(defun set-terminal-encoding (encoding-name)
209  #+windows-target (when (atom encoding-name)
210                     (setq encoding-name `(:character-encoding ,encoding-name
211                                           :line-termination :crlf)))
212  (let* ((exformat (normalize-external-format t encoding-name)))
213    (setf (stream-external-format *stdin*) exformat
214          (stream-external-format *stdout*) exformat
215          (stream-external-format *stderr*) exformat
216          (stream-external-format *terminal-input*) exformat
217          (stream-external-format *terminal-output*) exformat))
218  encoding-name)
219
220(catch :toplevel
221    (macrolet ((l1-load-provide (module path)
222                 `(let* ((*package* *package*))
223                   (l1-load ,path)
224                   (provide ,module)))
225               (bin-load-provide (module path)
226                 `(let* ((*package* *package*))
227                   (bin-load ,path)
228                   (provide ,module))))
229      (bin-load-provide "SORT" "sort")
230      (bin-load-provide "NUMBERS" "numbers")
231     
232      (bin-load-provide "SUBPRIMS" "subprims")
233      #+ppc32-target
234      (bin-load-provide "PPC32-ARCH" "ppc32-arch") 
235      #+ppc64-target
236      (bin-load-provide "PPC64-ARCH" "ppc64-arch")
237      #+x86-target
238      (bin-load-provide "X8632-ARCH" "x8632-arch")
239      #+x86-target
240      (bin-load-provide "X8664-ARCH" "x8664-arch")
241      #+arm-target
242      (bin-load-provide "ARM-ARCH" "arm-arch")
243      (bin-load-provide "VREG" "vreg")
244     
245      #+ppc-target
246      (bin-load-provide "PPC-ASM" "ppc-asm")
247      #+arm-target
248      (bin-load-provide "ARM-ASM" "arm-asm")
249     
250      (bin-load-provide "VINSN" "vinsn")
251      (bin-load-provide "REG" "reg")
252     
253      #+ppc-target
254      (bin-load-provide "PPC-LAP" "ppc-lap")
255      #+arm-target
256      (bin-load-provide "ARM-LAP" "arm-lap")
257      (bin-load-provide "BACKEND" "backend")
258      (bin-load-provide "NX2" "nx2")
259     
260      #+ppc-target
261      (provide "PPC2")                  ; Lie, load the module manually
262
263      #+x86-target
264      (provide "X862")
265
266      #+arm-target
267      (provide "ARM2") 
268      (bin-load-provide "ACODE-REWRITE" "acode-rewrite")
269     
270      (l1-load-provide "NX" "nx")
271     
272      #+ppc-target
273      (bin-load "ppc2")
274
275      #+x86-target
276      (bin-load "x862")
277
278      #+arm-target
279      (bin-load "arm2")
280     
281      (bin-load-provide "LEVEL-2" "level-2")
282      (bin-load-provide "MACROS" "macros")
283      (bin-load-provide "SETF" "setf")
284      (bin-load-provide "SETF-RUNTIME" "setf-runtime")
285      (bin-load-provide "FORMAT" "format")
286      (bin-load-provide "STREAMS" "streams")
287      (bin-load-provide "OPTIMIZERS" "optimizers")     
288      (bin-load-provide "DEFSTRUCT-MACROS" "defstruct-macros")
289      (bin-load-provide "DEFSTRUCT-LDS" "defstruct-lds")
290      (bin-load-provide "NFCOMP" "nfcomp")
291      (bin-load-provide "BACKQUOTE" "backquote")
292      (bin-load-provide "BACKTRACE-LDS" "backtrace-lds")
293      (bin-load-provide "BACKTRACE" "backtrace")
294      (bin-load-provide "READ" "read")
295      (bin-load-provide "ARRAYS-FRY" "arrays-fry")
296      (bin-load-provide "APROPOS" "apropos")
297      (bin-load-provide "SOURCE-FILES" "source-files")
298     
299      #+ppc-target
300      (progn
301        (bin-load-provide "PPC-DISASSEMBLE" "ppc-disassemble")
302        (bin-load-provide "PPC-LAPMACROS" "ppc-lapmacros"))
303
304      #+x86-target
305      (progn
306        (bin-load-provide "X86-DISASSEMBLE" "x86-disassemble")
307        (bin-load-provide "X86-LAPMACROS" "x86-lapmacros")
308        (bin-load "x86-watch"))
309
310      #+arm-target
311      (progn
312        (bin-load-provide "ARM-DISASSEMBLE" "arm-disassemble")
313        (bin-load-provide "ARM-LAPMACROS" "arm-lapmacros"))
314
315      (bin-load-provide "FOREIGN-TYPES" "foreign-types")
316      (install-standard-foreign-types *host-ftd*)
317     
318      #+(and ppc32-target linux-target)
319      (bin-load-provide "FFI-LINUXPPC32" "ffi-linuxppc32")
320      #+(and ppc32-target darwin-target)
321      (bin-load-provide "FFI-DARWINPPC32" "ffi-darwinppc32")
322      #+(and ppc64-target darwin-target)
323      (bin-load-provide "FFI-DARWINPPC64" "ffi-darwinppc64")
324      #+(and ppc64-target linux-target)
325      (bin-load-provide "FFI-LINUXPPC64" "ffi-linuxppc64")
326      #+(and x8632-target darwin-target)
327      (bin-load-provide "FFI-DARWINX8632" "ffi-darwinx8632")
328      #+(and x8664-target linux-target) 
329      (bin-load-provide "FFI-LINUXX8664" "ffi-linuxx8664")
330      #+(and x8664-target darwin-target) 
331      (bin-load-provide "FFI-DARWINX8664" "ffi-darwinx8664")
332      #+(and x8664-target freebsd-target) 
333      (bin-load-provide "FFI-FREEBSDX8664" "ffi-freebsdx8664")
334      #+(and x8664-target solaris-target)
335      (bin-load-provide "FFI-SOLARISX8664" "ffi-solarisx8664")
336      #+win64-target
337      (bin-load-provide "FFI-WIN64" "ffi-win64")
338      #+linuxx8632-target
339      (bin-load-provide "FFI-LINUXX8632" "ffi-linuxx8632")
340      #+win32-target
341      (bin-load-provide "FFI-WIN32" "ffi-win32")
342      #+solarisx8632-target
343      (bin-load-provide "FFI-SOLARISX8632" "ffi-solarisx8632")
344      #+freebsdx8632-target
345      (bin-load-provide "FFI-FREEBSDX8632" "ffi-freebsdx8632")
346      #+(and arm-target linux-target (not android-target))
347      (bin-load-provide "FFI-LINUXARM" "ffi-linuxarm")
348      #+(and arm-target android-target)
349      (bin-load-provide "FFI-ANDROIDARM" "ffi-androidarm")
350      #+(and arm-target darwin-target)
351      (bin-load-provide "FFI-DARWINARM" "ffi-darwinarm")
352
353
354      ;; Knock wood: all standard reader macros and no non-standard
355      ;; reader macros are defined at this point.
356      (setq *readtable* (copy-readtable *readtable*))
357
358      (bin-load-provide "DB-IO" "db-io")
359
360      (canonicalize-foreign-type-ordinals *host-ftd*)
361     
362      (bin-load-provide "CASE-ERROR" "case-error")
363      (bin-load-provide "ENCAPSULATE" "encapsulate")
364      (bin-load-provide "METHOD-COMBINATION" "method-combination")
365      (bin-load-provide "MISC" "misc")
366      (bin-load-provide "PPRINT" "pprint")
367      (bin-load-provide "DUMPLISP" "dumplisp")
368      (bin-load-provide "PATHNAMES" "pathnames")
369      (bin-load-provide "TIME" "time")
370      (bin-load-provide "COMPILE-CCL" "compile-ccl")
371      (bin-load-provide "ARGLIST" "arglist")
372      (bin-load-provide "EDIT-CALLERS" "edit-callers")
373      (bin-load-provide "DESCRIBE" "describe")
374      (bin-load-provide "SWINK" "swink")
375      (bin-load-provide "COVER" "cover")
376      (bin-load-provide "LEAKS" "leaks")
377      (bin-load-provide "CORE-FILES" "core-files")
378      (bin-load-provide "DOMINANCE" "dominance")
379      (bin-load-provide "SWANK-LOADER" "swank-loader")
380      (bin-load-provide "REMOTE-LISP" "remote-lisp")
381      (bin-load-provide "MCL-COMPAT" "mcl-compat")
382      (require "LOOP")
383      (bin-load-provide "CCL-EXPORT-SYMS" "ccl-export-syms")
384      (l1-load-provide "VERSION" "version")
385      (require "JP-ENCODE")
386      (require "CN-ENCODE")
387      (require "LISPEQU") ; Shouldn't need this at load time ...
388      )
389    (setq *%fasload-verbose* nil)
390    )
391)
392
393
394
395
396
397
Note: See TracBrowser for help on using the repository browser.