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
RevLine 
[6]1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
[13067]3;;;   Copyright (C) 2009 Clozure Associates
[6]4;;;   Copyright (C) 1994-2001 Digitool, Inc
[13066]5;;;   This file is part of Clozure CL. 
[6]6;;;
[13066]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
[6]9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
[13066]10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
[6]11;;;   conflict, the preamble takes precedence. 
12;;;
[13066]13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
[6]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
[2326]21(in-package "CCL")
[6]22
23(macrolet ((l1-load (name)
24             (let* ((namestring
25                     (concatenate 'simple-base-string
[3790]26                                  "./l1-fasls/"
[6]27                                  (string name)
[3786]28                                  (namestring (backend-target-fasl-pathname
29                                               *target-backend*)))))
[11373]30               `(let* ((*loading-file-source-file* *loading-file-source-file*)
31                       (*loading-toplevel-location* *loading-toplevel-location*))
32                  (%fasload ,namestring))))
[6]33           (bin-load (name)
34             (let* ((namestring
35                     (concatenate 'simple-base-string
[3790]36                                  "./bin/"
[6]37                                  (string name)
[3786]38                                  (namestring (backend-target-fasl-pathname
39                                               *target-backend*)))))
[11373]40               `(let* ((*loading-file-source-file* *loading-file-source-file*)
41                       (*loading-toplevel-location* *loading-toplevel-location*))
42                  (%fasload ,namestring)))))
[6]43
44
45(catch :toplevel
46    #+ppc-target
47    (l1-load "ppc-error-signal")
[3972]48    #+x86-target
49    (l1-load "x86-error-signal")
[14119]50    #+arm-target
51    (l1-load "arm-error-signal")
[6]52    (l1-load "l1-error-signal")
53    (l1-load "l1-sockets")
54    (setq *LEVEL-1-LOADED* t))
55
[3786]56#+ppc-target
[6]57(defun altivec-available-p ()
[2449]58  "Return non-NIL if AltiVec is available."
[955]59  (not (eql (%get-kernel-global 'ppc::altivec-present) 0)))
[6]60
[3786]61#+ppc-target
[2449]62(defloadvar *altivec-available* (altivec-available-p)
[13066]63  "This variable is intitialized each time a Clozure CL session starts based
[2449]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.")
[6]66
67       
[6186]68(defstatic *auto-flush-streams* ())
[6]69(def-ccl-pointers *auto-flush-streams* () (setq *auto-flush-streams* nil))
[6186]70(defstatic *auto-flush-streams-lock* (make-lock))
[6]71
72
[12166]73(defvar *batch-flag* (not (eql (%get-kernel-global 'batch-flag) 0)))
[2071]74(defloadvar *quiet-flag* nil)
[6]75(defvar *terminal-input* ())
76(defvar *terminal-output* ())
77(defvar *stdin* ())
78(defvar *stdout* ())
79(defvar *stderr* ())
80
[5290]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
[6]92;;; The hard parts here have to do with setting up *TERMINAL-IO*.
[2104]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.
[6]98
[10274]99(defglobal *interactive-streams-initialized* nil)
[6]100
[5314]101(defun initialize-interactive-streams ()
102  (let* ((encoding (lookup-character-encoding *terminal-character-encoding-name*))
103         (encoding-name (if encoding (character-encoding-name encoding))))
[11081]104    (setq *stdin* (make-fd-stream #-windows-target 0
105                                  #+windows-target (%ptr-to-int
106                                                    (#_GetStdHandle #$STD_INPUT_HANDLE))
[5314]107                                  :basic t
108                                  :sharing :lock
109                                  :direction :input
110                                  :interactive (not *batch-flag*)
[11817]111                                  :encoding encoding-name
112                                  #+windows-target :line-termination #+windows-target :cp/m))
[11081]113    (setq *stdout* (make-fd-stream #-windows-target 1
114                                   #+windows-target (%ptr-to-int
115                                                     (#_GetStdHandle #$STD_OUTPUT_HANDLE))
[11817]116                                   :basic t :direction :output :sharing :lock :encoding encoding-name #+windows-target :line-termination #+windows-target :msdos))
[11081]117    (setq *stderr* (make-fd-stream #-windows-target 2
118                                   #+windows-target (%ptr-to-int
119                                                     (#_GetStdHandle #$STD_ERROR_HANDLE))
[11817]120                    :basic t :direction :output :sharing :lock :encoding encoding-name #+windows-target :line-termination #+windows-target :crlf))
[5314]121    (if *batch-flag*
[10874]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)))))
[5314]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))
[6]163
[5314]164(initialize-interactive-streams)
[6]165
[6186]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*)
[6]172
[13562]173;;; Things bound by WITH-STANDARD-IO-SYNTAX (and not otherwise thread-local)
[13563]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*)
[13562]193;;; ccl extensions (see l1-io.lisp)
[13563]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*)
[6]199
[13562]200
[10274]201(defun set-terminal-encoding (encoding-name)
[11980]202  #+windows-target (when (atom encoding-name)
203                     (setq encoding-name `(:character-encoding ,encoding-name
204                                           :line-termination :crlf)))
[10274]205  (let* ((exformat (normalize-external-format t encoding-name)))
206    (setf (stream-external-format *stdin*) exformat
207          (stream-external-format *stdout*) exformat
[10280]208          (stream-external-format *stderr*) exformat
[10274]209          (stream-external-format *terminal-input*) exformat
210          (stream-external-format *terminal-output*) exformat))
211  encoding-name)
[5314]212
[6]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     
[2755]225      (bin-load-provide "SUBPRIMS" "subprims")
226      #+ppc32-target
[3826]227      (bin-load-provide "PPC32-ARCH" "ppc32-arch") 
[2755]228      #+ppc64-target
229      (bin-load-provide "PPC64-ARCH" "ppc64-arch")
[10201]230      #+x86-target
[10134]231      (bin-load-provide "X8632-ARCH" "x8632-arch")
[10201]232      #+x86-target
[3826]233      (bin-load-provide "X8664-ARCH" "x8664-arch")
[14119]234      #+arm-target
235      (bin-load-provide "ARM-ARCH" "arm-arch")
[6]236      (bin-load-provide "VREG" "vreg")
237     
238      #+ppc-target
239      (bin-load-provide "PPC-ASM" "ppc-asm")
[14119]240      #+arm-target
241      (bin-load-provide "ARM-ASM" "arm-asm")
[6]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")
[14119]248      #+arm-target
249      (bin-load-provide "ARM-LAP" "arm-lap")
[6]250      (bin-load-provide "BACKEND" "backend")
[11368]251      (bin-load-provide "NX2" "nx2")
[6]252     
253      #+ppc-target
254      (provide "PPC2")                  ; Lie, load the module manually
[3826]255
256      #+x86-target
257      (provide "X862")
[14119]258
259      #+arm-target
260      (provide "ARM2")
[6]261     
262      (l1-load-provide "NX" "nx")
263     
264      #+ppc-target
265      (bin-load "ppc2")
[3826]266
267      #+x86-target
268      (bin-load "x862")
[14119]269
270      #+arm-target
271      (bin-load "arm2")
[6]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")     
[3786]280      (bin-load-provide "DEFSTRUCT-MACROS" "defstruct-macros")
[6]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")
[11123]289      (bin-load-provide "SOURCE-FILES" "source-files")
[6]290     
291      #+ppc-target
292      (progn
293        (bin-load-provide "PPC-DISASSEMBLE" "ppc-disassemble")
294        (bin-load-provide "PPC-LAPMACROS" "ppc-lapmacros"))
295
[3826]296      #+x86-target
297      (progn
298        (bin-load-provide "X86-DISASSEMBLE" "x86-disassemble")
[13398]299        (bin-load-provide "X86-LAPMACROS" "x86-lapmacros")
300        (bin-load "x86-watch"))
[3826]301
[14119]302      #+arm-target
303      (progn
304        (bin-load-provide "ARM-DISASSEMBLE" "arm-disassemble")
305        (bin-load-provide "ARM-LAPMACROS" "arm-lapmacros"))
[12497]306
[6]307      (bin-load-provide "FOREIGN-TYPES" "foreign-types")
[6186]308      (install-standard-foreign-types *host-ftd*)
309     
[5740]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")
[10134]318      #+(and x8632-target darwin-target)
319      (bin-load-provide "FFI-DARWINX8632" "ffi-darwinx8632")
[5740]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")
[10051]326      #+(and x8664-target solaris-target)
327      (bin-load-provide "FFI-SOLARISX8664" "ffi-solarisx8664")
[10628]328      #+win64-target
329      (bin-load-provide "FFI-WIN64" "ffi-win64")
[10762]330      #+linuxx8632-target
331      (bin-load-provide "FFI-LINUXX8632" "ffi-linuxx8632")
[10894]332      #+win32-target
333      (bin-load-provide "FFI-WIN32" "ffi-win32")
[11253]334      #+solarisx8632-target
335      (bin-load-provide "FFI-SOLARISX8632" "ffi-solarisx8632")
[11483]336      #+freebsdx8632-target
337      (bin-load-provide "FFI-FREEBSDX8632" "ffi-freebsdx8632")
[14119]338      #+(and arm-target linux-target)
339      (bin-load-provide "FFI-LINUXARM" "ffi-linuxarm")
[12497]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
[6]346      (bin-load-provide "DB-IO" "db-io")
[6186]347
348      (canonicalize-foreign-type-ordinals *host-ftd*)
[6]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")
[12300]362      (bin-load-provide "COVER" "cover")
[11165]363      (bin-load-provide "LEAKS" "leaks")
[13085]364      (bin-load-provide "CORE-FILES" "core-files")
[13494]365      (bin-load-provide "DOMINANCE" "dominance")
[6]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")
[12385]370      (require "JP-ENCODE")
[3786]371      (require "LISPEQU") ; Shouldn't need this at load time ...
[6]372      )
373    (setq *%fasload-verbose* nil)
374    )
375)
376
377
378
379
380
381
Note: See TracBrowser for help on using the repository browser.