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

Last change on this file since 11123 was 11123, checked in by gz, 12 years ago

Move source-files earlier in loading sequence

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