source: branches/working-0711/ccl/level-1/l1-boot-2.lisp @ 11832

Last change on this file since 11832 was 11764, checked in by gz, 11 years ago

Reset *loading-file-source-file* and *loading-toplevel-location* to just before the non-local exit in level-1.lisp, don't bother resetting it earlier as it just gets overwritten.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 12.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                       (*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(defloadvar *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    (setq *stdout* (make-fd-stream #-windows-target 1
110                                   #+windows-target (%ptr-to-int
111                                                     (#_GetStdHandle #$STD_OUTPUT_HANDLE))
112                                   :basic t :direction :output :sharing :lock :encoding encoding-name))
113    (setq *stderr* (make-fd-stream #-windows-target 2
114                                   #+windows-target (%ptr-to-int
115                                                     (#_GetStdHandle #$STD_ERROR_HANDLE))
116                    :basic t :direction :output :sharing :lock :encoding encoding-name))
117    (if *batch-flag*
118      (let* ((tty-fd
119               #-windows-target
120               (let* ((fd (fd-open "/dev/tty" #$O_RDWR)))
121                 (if (>= fd 0) fd)))
122             (can-use-tty #-windows-target (and tty-fd (eql (tcgetpgrp tty-fd) (getpid)))))
123        (if can-use-tty
124          (setq
125           *terminal-input* (make-fd-stream tty-fd
126                                            :basic t
127                                            :direction :input
128                                            :interactive t
129                                            :sharing :lock
130                                            :encoding encoding-name)
131           *terminal-output* (make-fd-stream tty-fd :basic t :direction :output :sharing :lock :encoding encoding-name)
132           *terminal-io* (make-echoing-two-way-stream
133                          *terminal-input* *terminal-output*))
134          (progn
135            (when tty-fd (fd-close tty-fd))
136            (setq *terminal-input* *stdin*
137                  *terminal-output* *stdout*
138                  *terminal-io* (make-two-way-stream
139                                 *terminal-input* *terminal-output*))))
140        (setq *standard-input* *stdin*
141              *standard-output* *stdout*))
142      (progn
143        (setq *terminal-input* *stdin*
144              *terminal-output* *stdout*
145              *terminal-io* (make-echoing-two-way-stream
146                             *terminal-input* *terminal-output*))
147        (setq *standard-input* (make-synonym-stream '*terminal-io*)
148              *standard-output* (make-synonym-stream '*terminal-io*))))
149    (setq *error-output* (if *batch-flag*
150                           (make-synonym-stream '*stderr*)
151                           (make-synonym-stream '*terminal-io*)))
152    (setq *query-io* (make-synonym-stream '*terminal-io*))
153    (setq *debug-io* *query-io*)
154    (setq *trace-output* *standard-output*)
155    (push *stdout* *auto-flush-streams*)
156    (setf (input-stream-shared-resource *terminal-input*)
157          (make-shared-resource "Shared Terminal Input")))
158  (setq *interactive-streams-initialized* t))
159
160(initialize-interactive-streams)
161
162(def-standard-initial-binding *standard-input*)
163(def-standard-initial-binding *standard-output*)
164(def-standard-initial-binding *error-output*)
165(def-standard-initial-binding *trace-output*)
166(def-standard-initial-binding *debug-io*)
167(def-standard-initial-binding *query-io*)
168
169
170(defun set-terminal-encoding (encoding-name)
171  (let* ((exformat (normalize-external-format t encoding-name)))
172    (setf (stream-external-format *stdin*) exformat
173          (stream-external-format *stdout*) exformat
174          (stream-external-format *stderr*) exformat
175          (stream-external-format *terminal-input*) exformat
176          (stream-external-format *terminal-output*) exformat))
177  encoding-name)
178
179(catch :toplevel
180    (macrolet ((l1-load-provide (module path)
181                 `(let* ((*package* *package*))
182                   (l1-load ,path)
183                   (provide ,module)))
184               (bin-load-provide (module path)
185                 `(let* ((*package* *package*))
186                   (bin-load ,path)
187                   (provide ,module))))
188      (bin-load-provide "SORT" "sort")
189      (bin-load-provide "NUMBERS" "numbers")
190     
191      (bin-load-provide "SUBPRIMS" "subprims")
192      #+ppc32-target
193      (bin-load-provide "PPC32-ARCH" "ppc32-arch") 
194      #+ppc64-target
195      (bin-load-provide "PPC64-ARCH" "ppc64-arch")
196      #+x86-target
197      (bin-load-provide "X8632-ARCH" "x8632-arch")
198      #+x86-target
199      (bin-load-provide "X8664-ARCH" "x8664-arch")
200      (bin-load-provide "VREG" "vreg")
201     
202      #+ppc-target
203      (bin-load-provide "PPC-ASM" "ppc-asm")
204     
205      (bin-load-provide "VINSN" "vinsn")
206      (bin-load-provide "REG" "reg")
207     
208      #+ppc-target
209      (bin-load-provide "PPC-LAP" "ppc-lap")
210      (bin-load-provide "BACKEND" "backend")
211      (bin-load-provide "NX2" "nx2")
212     
213      #+ppc-target
214      (provide "PPC2")                  ; Lie, load the module manually
215
216      #+x86-target
217      (provide "X862")
218     
219      (l1-load-provide "NX" "nx")
220     
221      #+ppc-target
222      (bin-load "ppc2")
223
224      #+x86-target
225      (bin-load "x862")
226     
227      (bin-load-provide "LEVEL-2" "level-2")
228      (bin-load-provide "MACROS" "macros")
229      (bin-load-provide "SETF" "setf")
230      (bin-load-provide "SETF-RUNTIME" "setf-runtime")
231      (bin-load-provide "FORMAT" "format")
232      (bin-load-provide "STREAMS" "streams")
233      (bin-load-provide "OPTIMIZERS" "optimizers")     
234      (bin-load-provide "DEFSTRUCT-MACROS" "defstruct-macros")
235      (bin-load-provide "DEFSTRUCT-LDS" "defstruct-lds")
236      (bin-load-provide "NFCOMP" "nfcomp")
237      (bin-load-provide "BACKQUOTE" "backquote")
238      (bin-load-provide "BACKTRACE-LDS" "backtrace-lds")
239      (bin-load-provide "BACKTRACE" "backtrace")
240      (bin-load-provide "READ" "read")
241      (bin-load-provide "ARRAYS-FRY" "arrays-fry")
242      (bin-load-provide "APROPOS" "apropos")
243      (bin-load-provide "SOURCE-FILES" "source-files")
244     
245      #+ppc-target
246      (progn
247        (bin-load-provide "PPC-DISASSEMBLE" "ppc-disassemble")
248        (bin-load-provide "PPC-LAPMACROS" "ppc-lapmacros"))
249
250      #+x86-target
251      (progn
252        (bin-load-provide "X86-DISASSEMBLE" "x86-disassemble")
253        (bin-load-provide "X86-LAPMACROS" "x86-lapmacros"))
254     
255
256      (bin-load-provide "FOREIGN-TYPES" "foreign-types")
257      (install-standard-foreign-types *host-ftd*)
258     
259      #+(and ppc32-target linux-target)
260      (bin-load-provide "FFI-LINUXPPC32" "ffi-linuxppc32")
261      #+(and ppc32-target darwin-target)
262      (bin-load-provide "FFI-DARWINPPC32" "ffi-darwinppc32")
263      #+(and ppc64-target darwin-target)
264      (bin-load-provide "FFI-DARWINPPC64" "ffi-darwinppc64")
265      #+(and ppc64-target linux-target)
266      (bin-load-provide "FFI-LINUXPPC64" "ffi-linuxppc64")
267      #+(and x8632-target darwin-target)
268      (bin-load-provide "FFI-DARWINX8632" "ffi-darwinx8632")
269      #+(and x8664-target linux-target) 
270      (bin-load-provide "FFI-LINUXX8664" "ffi-linuxx8664")
271      #+(and x8664-target darwin-target) 
272      (bin-load-provide "FFI-DARWINX8664" "ffi-darwinx8664")
273      #+(and x8664-target freebsd-target) 
274      (bin-load-provide "FFI-FREEBSDX8664" "ffi-freebsdx8664")
275      #+(and x8664-target solaris-target)
276      (bin-load-provide "FFI-SOLARISX8664" "ffi-solarisx8664")
277      #+win64-target
278      (bin-load-provide "FFI-WIN64" "ffi-win64")
279      #+linuxx8632-target
280      (bin-load-provide "FFI-LINUXX8632" "ffi-linuxx8632")
281      #+win32-target
282      (bin-load-provide "FFI-WIN32" "ffi-win32")
283      #+solarisx8632-target
284      (bin-load-provide "FFI-SOLARISX8632" "ffi-solarisx8632")
285     
286      (bin-load-provide "DB-IO" "db-io")
287
288      (canonicalize-foreign-type-ordinals *host-ftd*)
289     
290      (bin-load-provide "CASE-ERROR" "case-error")
291      (bin-load-provide "ENCAPSULATE" "encapsulate")
292      (bin-load-provide "METHOD-COMBINATION" "method-combination")
293      (bin-load-provide "MISC" "misc")
294      (bin-load-provide "PPRINT" "pprint")
295      (bin-load-provide "DUMPLISP" "dumplisp")
296      (bin-load-provide "PATHNAMES" "pathnames")
297      (bin-load-provide "TIME" "time")
298      (bin-load-provide "COMPILE-CCL" "compile-ccl")
299      (bin-load-provide "ARGLIST" "arglist")
300      (bin-load-provide "EDIT-CALLERS" "edit-callers")
301      (bin-load-provide "DESCRIBE" "describe")
302      (bin-load-provide "COVER" "cover")
303      (bin-load-provide "LEAKS" "leaks")
304      (bin-load-provide "MCL-COMPAT" "mcl-compat")
305      (require "LOOP")
306      (bin-load-provide "CCL-EXPORT-SYMS" "ccl-export-syms")
307      (l1-load-provide "VERSION" "version")
308      (require "LISPEQU") ; Shouldn't need this at load time ...
309      )
310    (setq *%fasload-verbose* nil)
311    )
312)
313
314
315
316
317
318
Note: See TracBrowser for help on using the repository browser.