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

Last change on this file since 14288 was 14288, checked in by gb, 9 years ago

l1-boot-2.lisp:
In INITIALIZE-INTERACTIVE-STREAMS: ensure that *STDOUT*, *STDERR*, and

(if it's disjoint) *TERMINAL-OUTPUT* are auto-flushed.

linux-files.lisp:
#+windows-target Define GET-LAST-WINDOWS-ERROR, so that #_GetLastError
can be called from code that may have to run before the FFI is
initialized.
When prompting the user to type :Y, force output. (This may run on the
housekeeping thread, so that output may not get autoflushed.)

l0-cfm-support.lisp: if GET-SHARED-LIBRARY fails, signal the error on
the calling thread (even if the #_dlopen/whatever happens on the initial
thread); fixes ticket:742

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