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

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

Changes from ARM branch. Need testing ...

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