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

Last change on this file since 12219 was 12166, checked in by gb, 10 years ago

Set *batch-flag* based on kernel global value early in startup process
(before initializing streams).

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 12.7 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17;; l1-boot-2.lisp
18;; Second part of l1-boot
19
20(in-package "CCL")
21
22(macrolet ((l1-load (name)
23             (let* ((namestring
24                     (concatenate 'simple-base-string
25                                  "./l1-fasls/"
26                                  (string name)
27                                  (namestring (backend-target-fasl-pathname
28                                               *target-backend*)))))
29               `(let* ((*loading-file-source-file* *loading-file-source-file*)
30                       (*loading-toplevel-location* *loading-toplevel-location*))
31                  (%fasload ,namestring))))
32           (bin-load (name)
33             (let* ((namestring
34                     (concatenate 'simple-base-string
35                                  "./bin/"
36                                  (string name)
37                                  (namestring (backend-target-fasl-pathname
38                                               *target-backend*)))))
39               `(let* ((*loading-file-source-file* *loading-file-source-file*)
40                       (*loading-toplevel-location* *loading-toplevel-location*))
41                  (%fasload ,namestring)))))
42
43
44(catch :toplevel
45    #+ppc-target
46    (l1-load "ppc-error-signal")
47    #+x86-target
48    (l1-load "x86-error-signal")
49    (l1-load "l1-error-signal")
50    (l1-load "l1-sockets")
51    (setq *LEVEL-1-LOADED* t))
52
53#+ppc-target
54(defun altivec-available-p ()
55  "Return non-NIL if AltiVec is available."
56  (not (eql (%get-kernel-global 'ppc::altivec-present) 0)))
57
58#+ppc-target
59(defloadvar *altivec-available* (altivec-available-p)
60  "This variable is intitialized each time an OpenMCL session starts based
61on information provided by the lisp kernel. Its value is true if AltiVec is
62present and false otherwise. This variable shouldn't be set by user code.")
63
64       
65(defstatic *auto-flush-streams* ())
66(def-ccl-pointers *auto-flush-streams* () (setq *auto-flush-streams* nil))
67(defstatic *auto-flush-streams-lock* (make-lock))
68
69
70(defvar *batch-flag* (not (eql (%get-kernel-global 'batch-flag) 0)))
71(defloadvar *quiet-flag* nil)
72(defvar *terminal-input* ())
73(defvar *terminal-output* ())
74(defvar *stdin* ())
75(defvar *stdout* ())
76(defvar *stderr* ())
77
78
79(defun set-basic-stream-prototype (class)
80  (when (subtypep class 'basic-stream)
81    (setf (%class.prototype class) (or (%class.prototype class)
82                                       (allocate-basic-stream class)))
83    (dolist (subclass (class-direct-subclasses class))
84      (set-basic-stream-prototype subclass))))
85
86(set-basic-stream-prototype (find-class 'basic-stream))
87
88
89;;; The hard parts here have to do with setting up *TERMINAL-IO*.
90;;; Note that opening /dev/tty can fail, and that failure would
91;;; be reported as a negative return value from FD-OPEN.
92;;; It's pretty important that nothing signals an error here,
93;;; since there may not be any valid streams to write an error
94;;; message to.
95
96(defglobal *interactive-streams-initialized* nil)
97
98(defun initialize-interactive-streams ()
99  (let* ((encoding (lookup-character-encoding *terminal-character-encoding-name*))
100         (encoding-name (if encoding (character-encoding-name encoding))))
101    (setq *stdin* (make-fd-stream #-windows-target 0
102                                  #+windows-target (%ptr-to-int
103                                                    (#_GetStdHandle #$STD_INPUT_HANDLE))
104                                  :basic t
105                                  :sharing :lock
106                                  :direction :input
107                                  :interactive (not *batch-flag*)
108                                  :encoding encoding-name
109                                  #+windows-target :line-termination #+windows-target :cp/m))
110    (setq *stdout* (make-fd-stream #-windows-target 1
111                                   #+windows-target (%ptr-to-int
112                                                     (#_GetStdHandle #$STD_OUTPUT_HANDLE))
113                                   :basic t :direction :output :sharing :lock :encoding encoding-name #+windows-target :line-termination #+windows-target :msdos))
114    (setq *stderr* (make-fd-stream #-windows-target 2
115                                   #+windows-target (%ptr-to-int
116                                                     (#_GetStdHandle #$STD_ERROR_HANDLE))
117                    :basic t :direction :output :sharing :lock :encoding encoding-name #+windows-target :line-termination #+windows-target :crlf))
118    (if *batch-flag*
119      (let* ((tty-fd
120               #-windows-target
121               (let* ((fd (fd-open "/dev/tty" #$O_RDWR)))
122                 (if (>= fd 0) fd)))
123             (can-use-tty #-windows-target (and tty-fd (eql (tcgetpgrp tty-fd) (getpid)))))
124        (if can-use-tty
125          (setq
126           *terminal-input* (make-fd-stream tty-fd
127                                            :basic t
128                                            :direction :input
129                                            :interactive t
130                                            :sharing :lock
131                                            :encoding encoding-name)
132           *terminal-output* (make-fd-stream tty-fd :basic t :direction :output :sharing :lock :encoding encoding-name)
133           *terminal-io* (make-echoing-two-way-stream
134                          *terminal-input* *terminal-output*))
135          (progn
136            (when tty-fd (fd-close tty-fd))
137            (setq *terminal-input* *stdin*
138                  *terminal-output* *stdout*
139                  *terminal-io* (make-two-way-stream
140                                 *terminal-input* *terminal-output*))))
141        (setq *standard-input* *stdin*
142              *standard-output* *stdout*))
143      (progn
144        (setq *terminal-input* *stdin*
145              *terminal-output* *stdout*
146              *terminal-io* (make-echoing-two-way-stream
147                             *terminal-input* *terminal-output*))
148        (setq *standard-input* (make-synonym-stream '*terminal-io*)
149              *standard-output* (make-synonym-stream '*terminal-io*))))
150    (setq *error-output* (if *batch-flag*
151                           (make-synonym-stream '*stderr*)
152                           (make-synonym-stream '*terminal-io*)))
153    (setq *query-io* (make-synonym-stream '*terminal-io*))
154    (setq *debug-io* *query-io*)
155    (setq *trace-output* *standard-output*)
156    (push *stdout* *auto-flush-streams*)
157    (setf (input-stream-shared-resource *terminal-input*)
158          (make-shared-resource "Shared Terminal Input")))
159  (setq *interactive-streams-initialized* t))
160
161(initialize-interactive-streams)
162
163(def-standard-initial-binding *standard-input*)
164(def-standard-initial-binding *standard-output*)
165(def-standard-initial-binding *error-output*)
166(def-standard-initial-binding *trace-output*)
167(def-standard-initial-binding *debug-io*)
168(def-standard-initial-binding *query-io*)
169
170
171(defun set-terminal-encoding (encoding-name)
172  #+windows-target (when (atom encoding-name)
173                     (setq encoding-name `(:character-encoding ,encoding-name
174                                           :line-termination :crlf)))
175  (let* ((exformat (normalize-external-format t encoding-name)))
176    (setf (stream-external-format *stdin*) exformat
177          (stream-external-format *stdout*) exformat
178          (stream-external-format *stderr*) exformat
179          (stream-external-format *terminal-input*) exformat
180          (stream-external-format *terminal-output*) exformat))
181  encoding-name)
182
183(catch :toplevel
184    (macrolet ((l1-load-provide (module path)
185                 `(let* ((*package* *package*))
186                   (l1-load ,path)
187                   (provide ,module)))
188               (bin-load-provide (module path)
189                 `(let* ((*package* *package*))
190                   (bin-load ,path)
191                   (provide ,module))))
192      (bin-load-provide "SORT" "sort")
193      (bin-load-provide "NUMBERS" "numbers")
194     
195      (bin-load-provide "SUBPRIMS" "subprims")
196      #+ppc32-target
197      (bin-load-provide "PPC32-ARCH" "ppc32-arch") 
198      #+ppc64-target
199      (bin-load-provide "PPC64-ARCH" "ppc64-arch")
200      #+x86-target
201      (bin-load-provide "X8632-ARCH" "x8632-arch")
202      #+x86-target
203      (bin-load-provide "X8664-ARCH" "x8664-arch")
204      (bin-load-provide "VREG" "vreg")
205     
206      #+ppc-target
207      (bin-load-provide "PPC-ASM" "ppc-asm")
208     
209      (bin-load-provide "VINSN" "vinsn")
210      (bin-load-provide "REG" "reg")
211     
212      #+ppc-target
213      (bin-load-provide "PPC-LAP" "ppc-lap")
214      (bin-load-provide "BACKEND" "backend")
215      (bin-load-provide "NX2" "nx2")
216     
217      #+ppc-target
218      (provide "PPC2")                  ; Lie, load the module manually
219
220      #+x86-target
221      (provide "X862")
222     
223      (l1-load-provide "NX" "nx")
224     
225      #+ppc-target
226      (bin-load "ppc2")
227
228      #+x86-target
229      (bin-load "x862")
230     
231      (bin-load-provide "LEVEL-2" "level-2")
232      (bin-load-provide "MACROS" "macros")
233      (bin-load-provide "SETF" "setf")
234      (bin-load-provide "SETF-RUNTIME" "setf-runtime")
235      (bin-load-provide "FORMAT" "format")
236      (bin-load-provide "STREAMS" "streams")
237      (bin-load-provide "OPTIMIZERS" "optimizers")     
238      (bin-load-provide "DEFSTRUCT-MACROS" "defstruct-macros")
239      (bin-load-provide "DEFSTRUCT-LDS" "defstruct-lds")
240      (bin-load-provide "NFCOMP" "nfcomp")
241      (bin-load-provide "BACKQUOTE" "backquote")
242      (bin-load-provide "BACKTRACE-LDS" "backtrace-lds")
243      (bin-load-provide "BACKTRACE" "backtrace")
244      (bin-load-provide "READ" "read")
245      (bin-load-provide "ARRAYS-FRY" "arrays-fry")
246      (bin-load-provide "APROPOS" "apropos")
247      (bin-load-provide "SOURCE-FILES" "source-files")
248     
249      #+ppc-target
250      (progn
251        (bin-load-provide "PPC-DISASSEMBLE" "ppc-disassemble")
252        (bin-load-provide "PPC-LAPMACROS" "ppc-lapmacros"))
253
254      #+x86-target
255      (progn
256        (bin-load-provide "X86-DISASSEMBLE" "x86-disassemble")
257        (bin-load-provide "X86-LAPMACROS" "x86-lapmacros"))
258     
259
260      (bin-load-provide "FOREIGN-TYPES" "foreign-types")
261      (install-standard-foreign-types *host-ftd*)
262     
263      #+(and ppc32-target linux-target)
264      (bin-load-provide "FFI-LINUXPPC32" "ffi-linuxppc32")
265      #+(and ppc32-target darwin-target)
266      (bin-load-provide "FFI-DARWINPPC32" "ffi-darwinppc32")
267      #+(and ppc64-target darwin-target)
268      (bin-load-provide "FFI-DARWINPPC64" "ffi-darwinppc64")
269      #+(and ppc64-target linux-target)
270      (bin-load-provide "FFI-LINUXPPC64" "ffi-linuxppc64")
271      #+(and x8632-target darwin-target)
272      (bin-load-provide "FFI-DARWINX8632" "ffi-darwinx8632")
273      #+(and x8664-target linux-target) 
274      (bin-load-provide "FFI-LINUXX8664" "ffi-linuxx8664")
275      #+(and x8664-target darwin-target) 
276      (bin-load-provide "FFI-DARWINX8664" "ffi-darwinx8664")
277      #+(and x8664-target freebsd-target) 
278      (bin-load-provide "FFI-FREEBSDX8664" "ffi-freebsdx8664")
279      #+(and x8664-target solaris-target)
280      (bin-load-provide "FFI-SOLARISX8664" "ffi-solarisx8664")
281      #+win64-target
282      (bin-load-provide "FFI-WIN64" "ffi-win64")
283      #+linuxx8632-target
284      (bin-load-provide "FFI-LINUXX8632" "ffi-linuxx8632")
285      #+win32-target
286      (bin-load-provide "FFI-WIN32" "ffi-win32")
287      #+solarisx8632-target
288      (bin-load-provide "FFI-SOLARISX8632" "ffi-solarisx8632")
289      #+freebsdx8632-target
290      (bin-load-provide "FFI-FREEBSDX8632" "ffi-freebsdx8632")
291     
292      (bin-load-provide "DB-IO" "db-io")
293
294      (canonicalize-foreign-type-ordinals *host-ftd*)
295     
296      (bin-load-provide "CASE-ERROR" "case-error")
297      (bin-load-provide "ENCAPSULATE" "encapsulate")
298      (bin-load-provide "METHOD-COMBINATION" "method-combination")
299      (bin-load-provide "MISC" "misc")
300      (bin-load-provide "PPRINT" "pprint")
301      (bin-load-provide "DUMPLISP" "dumplisp")
302      (bin-load-provide "PATHNAMES" "pathnames")
303      (bin-load-provide "TIME" "time")
304      (bin-load-provide "COMPILE-CCL" "compile-ccl")
305      (bin-load-provide "ARGLIST" "arglist")
306      (bin-load-provide "EDIT-CALLERS" "edit-callers")
307      (bin-load-provide "DESCRIBE" "describe")
308      (bin-load-provide "LEAKS" "leaks")
309      (bin-load-provide "MCL-COMPAT" "mcl-compat")
310      (require "LOOP")
311      (bin-load-provide "CCL-EXPORT-SYMS" "ccl-export-syms")
312      (l1-load-provide "VERSION" "version")
313      (require "LISPEQU") ; Shouldn't need this at load time ...
314      )
315    (setq *%fasload-verbose* nil)
316    )
317)
318
319
320
321
322
323
Note: See TracBrowser for help on using the repository browser.