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

Last change on this file since 10874 was 10874, checked in by gb, 11 years ago

In INITIALIZE-INTERACTIVE-STREAMS: don't muck with /dev/tty on Windows.

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