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

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

Bind newly per-process I/O variables to their static/default values,
not to the values that WITH-STANDARD-IO-SYNTAX considers "standard."

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 14.3 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    (l1-load "l1-error-signal")
51    (l1-load "l1-sockets")
52    (setq *LEVEL-1-LOADED* t))
53
54#+ppc-target
55(defun altivec-available-p ()
56  "Return non-NIL if AltiVec is available."
57  (not (eql (%get-kernel-global 'ppc::altivec-present) 0)))
58
59#+ppc-target
60(defloadvar *altivec-available* (altivec-available-p)
61  "This variable is intitialized each time a Clozure CL session starts based
62on information provided by the lisp kernel. Its value is true if AltiVec is
63present and false otherwise. This variable shouldn't be set by user code.")
64
65       
66(defstatic *auto-flush-streams* ())
67(def-ccl-pointers *auto-flush-streams* () (setq *auto-flush-streams* nil))
68(defstatic *auto-flush-streams-lock* (make-lock))
69
70
71(defvar *batch-flag* (not (eql (%get-kernel-global 'batch-flag) 0)))
72(defloadvar *quiet-flag* nil)
73(defvar *terminal-input* ())
74(defvar *terminal-output* ())
75(defvar *stdin* ())
76(defvar *stdout* ())
77(defvar *stderr* ())
78
79
80(defun set-basic-stream-prototype (class)
81  (when (subtypep class 'basic-stream)
82    (setf (%class.prototype class) (or (%class.prototype class)
83                                       (allocate-basic-stream class)))
84    (dolist (subclass (class-direct-subclasses class))
85      (set-basic-stream-prototype subclass))))
86
87(set-basic-stream-prototype (find-class 'basic-stream))
88
89
90;;; The hard parts here have to do with setting up *TERMINAL-IO*.
91;;; Note that opening /dev/tty can fail, and that failure would
92;;; be reported as a negative return value from FD-OPEN.
93;;; It's pretty important that nothing signals an error here,
94;;; since there may not be any valid streams to write an error
95;;; message to.
96
97(defglobal *interactive-streams-initialized* nil)
98
99(defun initialize-interactive-streams ()
100  (let* ((encoding (lookup-character-encoding *terminal-character-encoding-name*))
101         (encoding-name (if encoding (character-encoding-name encoding))))
102    (setq *stdin* (make-fd-stream #-windows-target 0
103                                  #+windows-target (%ptr-to-int
104                                                    (#_GetStdHandle #$STD_INPUT_HANDLE))
105                                  :basic t
106                                  :sharing :lock
107                                  :direction :input
108                                  :interactive (not *batch-flag*)
109                                  :encoding encoding-name
110                                  #+windows-target :line-termination #+windows-target :cp/m))
111    (setq *stdout* (make-fd-stream #-windows-target 1
112                                   #+windows-target (%ptr-to-int
113                                                     (#_GetStdHandle #$STD_OUTPUT_HANDLE))
114                                   :basic t :direction :output :sharing :lock :encoding encoding-name #+windows-target :line-termination #+windows-target :msdos))
115    (setq *stderr* (make-fd-stream #-windows-target 2
116                                   #+windows-target (%ptr-to-int
117                                                     (#_GetStdHandle #$STD_ERROR_HANDLE))
118                    :basic t :direction :output :sharing :lock :encoding encoding-name #+windows-target :line-termination #+windows-target :crlf))
119    (if *batch-flag*
120      (let* ((tty-fd
121               #-windows-target
122               (let* ((fd (fd-open "/dev/tty" #$O_RDWR)))
123                 (if (>= fd 0) fd)))
124             (can-use-tty #-windows-target (and tty-fd (eql (tcgetpgrp tty-fd) (getpid)))))
125        (if can-use-tty
126          (setq
127           *terminal-input* (make-fd-stream tty-fd
128                                            :basic t
129                                            :direction :input
130                                            :interactive t
131                                            :sharing :lock
132                                            :encoding encoding-name)
133           *terminal-output* (make-fd-stream tty-fd :basic t :direction :output :sharing :lock :encoding encoding-name)
134           *terminal-io* (make-echoing-two-way-stream
135                          *terminal-input* *terminal-output*))
136          (progn
137            (when tty-fd (fd-close tty-fd))
138            (setq *terminal-input* *stdin*
139                  *terminal-output* *stdout*
140                  *terminal-io* (make-two-way-stream
141                                 *terminal-input* *terminal-output*))))
142        (setq *standard-input* *stdin*
143              *standard-output* *stdout*))
144      (progn
145        (setq *terminal-input* *stdin*
146              *terminal-output* *stdout*
147              *terminal-io* (make-echoing-two-way-stream
148                             *terminal-input* *terminal-output*))
149        (setq *standard-input* (make-synonym-stream '*terminal-io*)
150              *standard-output* (make-synonym-stream '*terminal-io*))))
151    (setq *error-output* (if *batch-flag*
152                           (make-synonym-stream '*stderr*)
153                           (make-synonym-stream '*terminal-io*)))
154    (setq *query-io* (make-synonym-stream '*terminal-io*))
155    (setq *debug-io* *query-io*)
156    (setq *trace-output* *standard-output*)
157    (push *stdout* *auto-flush-streams*)
158    (setf (input-stream-shared-resource *terminal-input*)
159          (make-shared-resource "Shared Terminal Input")))
160  (setq *interactive-streams-initialized* t))
161
162(initialize-interactive-streams)
163
164(def-standard-initial-binding *standard-input*)
165(def-standard-initial-binding *standard-output*)
166(def-standard-initial-binding *error-output*)
167(def-standard-initial-binding *trace-output*)
168(def-standard-initial-binding *debug-io*)
169(def-standard-initial-binding *query-io*)
170
171;;; Things bound by WITH-STANDARD-IO-SYNTAX (and not otherwise thread-local)
172(def-standard-initial-binding *print-array*)
173(def-standard-initial-binding *print-base*)
174(def-standard-initial-binding *print-case*)
175(def-standard-initial-binding *print-circle*)
176(def-standard-initial-binding *print-escape*)
177(def-standard-initial-binding *print-gensym*)
178(def-standard-initial-binding *print-length*)
179(def-standard-initial-binding *print-level*)
180(def-standard-initial-binding *print-lines*) 
181(def-standard-initial-binding *print-miser-width*)
182(def-standard-initial-binding *print-pprint-dispatch*)
183(def-standard-initial-binding *print-pretty*)
184(def-standard-initial-binding *print-radix*)
185(def-standard-initial-binding *print-readably*)
186(def-standard-initial-binding *print-right-margin*)
187(def-standard-initial-binding *read-base*)
188(def-standard-initial-binding *read-default-float-format*)
189(def-standard-initial-binding *read-eval*) 
190(def-standard-initial-binding *read-suppress*)
191;;; ccl extensions (see l1-io.lisp)
192(def-standard-initial-binding *print-abbreviate-quote*)
193(def-standard-initial-binding *print-structure*)
194(def-standard-initial-binding *print-simple-vector*)
195(def-standard-initial-binding *print-simple-bit-vector*)
196(def-standard-initial-binding *print-string-length*)
197
198
199(defun set-terminal-encoding (encoding-name)
200  #+windows-target (when (atom encoding-name)
201                     (setq encoding-name `(:character-encoding ,encoding-name
202                                           :line-termination :crlf)))
203  (let* ((exformat (normalize-external-format t encoding-name)))
204    (setf (stream-external-format *stdin*) exformat
205          (stream-external-format *stdout*) exformat
206          (stream-external-format *stderr*) exformat
207          (stream-external-format *terminal-input*) exformat
208          (stream-external-format *terminal-output*) exformat))
209  encoding-name)
210
211(catch :toplevel
212    (macrolet ((l1-load-provide (module path)
213                 `(let* ((*package* *package*))
214                   (l1-load ,path)
215                   (provide ,module)))
216               (bin-load-provide (module path)
217                 `(let* ((*package* *package*))
218                   (bin-load ,path)
219                   (provide ,module))))
220      (bin-load-provide "SORT" "sort")
221      (bin-load-provide "NUMBERS" "numbers")
222     
223      (bin-load-provide "SUBPRIMS" "subprims")
224      #+ppc32-target
225      (bin-load-provide "PPC32-ARCH" "ppc32-arch") 
226      #+ppc64-target
227      (bin-load-provide "PPC64-ARCH" "ppc64-arch")
228      #+x86-target
229      (bin-load-provide "X8632-ARCH" "x8632-arch")
230      #+x86-target
231      (bin-load-provide "X8664-ARCH" "x8664-arch")
232      (bin-load-provide "VREG" "vreg")
233     
234      #+ppc-target
235      (bin-load-provide "PPC-ASM" "ppc-asm")
236     
237      (bin-load-provide "VINSN" "vinsn")
238      (bin-load-provide "REG" "reg")
239     
240      #+ppc-target
241      (bin-load-provide "PPC-LAP" "ppc-lap")
242      (bin-load-provide "BACKEND" "backend")
243      (bin-load-provide "NX2" "nx2")
244     
245      #+ppc-target
246      (provide "PPC2")                  ; Lie, load the module manually
247
248      #+x86-target
249      (provide "X862")
250     
251      (l1-load-provide "NX" "nx")
252     
253      #+ppc-target
254      (bin-load "ppc2")
255
256      #+x86-target
257      (bin-load "x862")
258     
259      (bin-load-provide "LEVEL-2" "level-2")
260      (bin-load-provide "MACROS" "macros")
261      (bin-load-provide "SETF" "setf")
262      (bin-load-provide "SETF-RUNTIME" "setf-runtime")
263      (bin-load-provide "FORMAT" "format")
264      (bin-load-provide "STREAMS" "streams")
265      (bin-load-provide "OPTIMIZERS" "optimizers")     
266      (bin-load-provide "DEFSTRUCT-MACROS" "defstruct-macros")
267      (bin-load-provide "DEFSTRUCT-LDS" "defstruct-lds")
268      (bin-load-provide "NFCOMP" "nfcomp")
269      (bin-load-provide "BACKQUOTE" "backquote")
270      (bin-load-provide "BACKTRACE-LDS" "backtrace-lds")
271      (bin-load-provide "BACKTRACE" "backtrace")
272      (bin-load-provide "READ" "read")
273      (bin-load-provide "ARRAYS-FRY" "arrays-fry")
274      (bin-load-provide "APROPOS" "apropos")
275      (bin-load-provide "SOURCE-FILES" "source-files")
276     
277      #+ppc-target
278      (progn
279        (bin-load-provide "PPC-DISASSEMBLE" "ppc-disassemble")
280        (bin-load-provide "PPC-LAPMACROS" "ppc-lapmacros"))
281
282      #+x86-target
283      (progn
284        (bin-load-provide "X86-DISASSEMBLE" "x86-disassemble")
285        (bin-load-provide "X86-LAPMACROS" "x86-lapmacros")
286        (bin-load "x86-watch"))
287
288
289      (bin-load-provide "FOREIGN-TYPES" "foreign-types")
290      (install-standard-foreign-types *host-ftd*)
291     
292      #+(and ppc32-target linux-target)
293      (bin-load-provide "FFI-LINUXPPC32" "ffi-linuxppc32")
294      #+(and ppc32-target darwin-target)
295      (bin-load-provide "FFI-DARWINPPC32" "ffi-darwinppc32")
296      #+(and ppc64-target darwin-target)
297      (bin-load-provide "FFI-DARWINPPC64" "ffi-darwinppc64")
298      #+(and ppc64-target linux-target)
299      (bin-load-provide "FFI-LINUXPPC64" "ffi-linuxppc64")
300      #+(and x8632-target darwin-target)
301      (bin-load-provide "FFI-DARWINX8632" "ffi-darwinx8632")
302      #+(and x8664-target linux-target) 
303      (bin-load-provide "FFI-LINUXX8664" "ffi-linuxx8664")
304      #+(and x8664-target darwin-target) 
305      (bin-load-provide "FFI-DARWINX8664" "ffi-darwinx8664")
306      #+(and x8664-target freebsd-target) 
307      (bin-load-provide "FFI-FREEBSDX8664" "ffi-freebsdx8664")
308      #+(and x8664-target solaris-target)
309      (bin-load-provide "FFI-SOLARISX8664" "ffi-solarisx8664")
310      #+win64-target
311      (bin-load-provide "FFI-WIN64" "ffi-win64")
312      #+linuxx8632-target
313      (bin-load-provide "FFI-LINUXX8632" "ffi-linuxx8632")
314      #+win32-target
315      (bin-load-provide "FFI-WIN32" "ffi-win32")
316      #+solarisx8632-target
317      (bin-load-provide "FFI-SOLARISX8632" "ffi-solarisx8632")
318      #+freebsdx8632-target
319      (bin-load-provide "FFI-FREEBSDX8632" "ffi-freebsdx8632")
320
321
322      ;; Knock wood: all standard reader macros and no non-standard
323      ;; reader macros are defined at this point.
324      (setq *readtable* (copy-readtable *readtable*))
325
326      (bin-load-provide "DB-IO" "db-io")
327
328      (canonicalize-foreign-type-ordinals *host-ftd*)
329     
330      (bin-load-provide "CASE-ERROR" "case-error")
331      (bin-load-provide "ENCAPSULATE" "encapsulate")
332      (bin-load-provide "METHOD-COMBINATION" "method-combination")
333      (bin-load-provide "MISC" "misc")
334      (bin-load-provide "PPRINT" "pprint")
335      (bin-load-provide "DUMPLISP" "dumplisp")
336      (bin-load-provide "PATHNAMES" "pathnames")
337      (bin-load-provide "TIME" "time")
338      (bin-load-provide "COMPILE-CCL" "compile-ccl")
339      (bin-load-provide "ARGLIST" "arglist")
340      (bin-load-provide "EDIT-CALLERS" "edit-callers")
341      (bin-load-provide "DESCRIBE" "describe")
342      (bin-load-provide "COVER" "cover")
343      (bin-load-provide "LEAKS" "leaks")
344      (bin-load-provide "CORE-FILES" "core-files")
345      (bin-load-provide "DOMINANCE" "dominance")
346      (bin-load-provide "MCL-COMPAT" "mcl-compat")
347      (require "LOOP")
348      (bin-load-provide "CCL-EXPORT-SYMS" "ccl-export-syms")
349      (l1-load-provide "VERSION" "version")
350      (require "JP-ENCODE")
351      (require "LISPEQU") ; Shouldn't need this at load time ...
352      )
353    (setq *%fasload-verbose* nil)
354    )
355)
356
357
358
359
360
361
Note: See TracBrowser for help on using the repository browser.