/[cmucl]/src/code/lispinit.lisp
ViewVC logotype

Diff of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.49.2.6 by pw, Sat Mar 23 18:50:03 2002 UTC revision 1.82 by rtoy, Tue Apr 20 17:57:44 2010 UTC
# Line 15  Line 15 
15  ;;; Written by Skef Wholey and Rob MacLachlan.  ;;; Written by Skef Wholey and Rob MacLachlan.
16  ;;;  ;;;
17  (in-package :lisp)  (in-package :lisp)
18    (intl:textdomain "cmucl")
19    
20  (export '(most-positive-fixnum most-negative-fixnum sleep  (export '(most-positive-fixnum most-negative-fixnum sleep
21            ++ +++ ** *** // ///))            ++ +++ ** *** // ///))
22    
23    (defvar *features* '(:common :common-lisp :ansi-cl :ieee-floating-point :cmu)
24      "Holds a list of symbols that describe features provided by the
25       implementation.")
26    
27    
28  (in-package :system)  (in-package :system)
29  (export '(compiler-version scrub-control-stack))  (export '(compiler-version scrub-control-stack *runtime-features*))
30    
31    (defvar *runtime-features* nil
32      "Features affecting the runtime")
33    
34  (in-package :extensions)  (in-package :extensions)
35  (export '(quit *prompt*))  (export '(quit *prompt*))
36    
37  (in-package :lisp)  (in-package :lisp)
38    
39    #+stack-checking
40    (sys:register-lisp-runtime-feature :stack-checking)
41    
42    #+heap-overflow-check
43    (sys:register-lisp-runtime-feature :heap-overflow-check)
44    
45    #+double-double
46    (sys:register-lisp-feature :double-double)
47    
48  ;;; Make the error system enable interrupts.  ;;; Make the error system enable interrupts.
49    
50  (defconstant most-positive-fixnum #.vm:target-most-positive-fixnum  (defconstant most-positive-fixnum #.vm:target-most-positive-fixnum
# Line 51  Line 69 
69             #+x86 *pseudo-atomic-interrupted*             #+x86 *pseudo-atomic-interrupted*
70             unix::*interrupts-enabled*             unix::*interrupts-enabled*
71             unix::*interrupt-pending*             unix::*interrupt-pending*
72             *type-system-initialized*)             *type-system-initialized*
73               unix::*filename-encoding*)
74    #+gengc    #+gengc
75    (special *gc-verbose* *before-gc-hooks* *after-gc-hooks*    (special *gc-verbose* *before-gc-hooks* *after-gc-hooks*
76             *type-system-initialized*))             *type-system-initialized* unix::*filename-encoding*))
77    
78    
79  ;;;; Random magic specials.  ;;;; Random magic specials.
# Line 137  Line 156 
156      (let ((obos *break-on-signals*)      (let ((obos *break-on-signals*)
157            (*break-on-signals* nil))            (*break-on-signals* nil))
158        (when (typep condition obos)        (when (typep condition obos)
159          (break "~A~%Break entered because of *break-on-signals* (now NIL.)"          (break (intl:gettext "~A~%Break entered because of *break-on-signals* (now NIL.)")
160                 condition)))                 condition)))
161      (loop      (loop
162        (unless *handler-clusters* (return))        (unless *handler-clusters* (return))
# Line 154  Line 173 
173  (defun coerce-to-condition (datum arguments default-type function-name)  (defun coerce-to-condition (datum arguments default-type function-name)
174    (cond ((typep datum 'condition)    (cond ((typep datum 'condition)
175           (if arguments           (if arguments
176               (cerror "Ignore the additional arguments."               (cerror (intl:gettext "Ignore the additional arguments.")
177                       'simple-type-error                       'simple-type-error
178                       :datum arguments                       :datum arguments
179                       :expected-type 'null                       :expected-type 'null
180                       :format-control "You may not supply additional arguments ~                       :format-control (intl:gettext "You may not supply additional arguments ~
181                                       when giving ~S to ~S."                                       when giving ~S to ~S.")
182                       :format-arguments (list datum function-name)))                       :format-arguments (list datum function-name)))
183           datum)           datum)
184          ((symbolp datum) ;Roughly, (subtypep datum 'condition).          ((symbolp datum) ;Roughly, (subtypep datum 'condition).
# Line 172  Line 191 
191           (error 'simple-type-error           (error 'simple-type-error
192                  :datum datum                  :datum datum
193                  :expected-type '(or symbol string)                  :expected-type '(or symbol string)
194                  :format-control "Bad argument to ~S: ~S"                  :format-control (intl:gettext "Bad argument to ~S: ~S")
195                  :format-arguments (list function-name datum)))))                  :format-arguments (list function-name datum)))))
196    
197  (defun error (datum &rest arguments)  (defun error (datum &rest arguments)
# Line 225  Line 244 
244    "Prints a message and invokes the debugger without allowing any possibility    "Prints a message and invokes the debugger without allowing any possibility
245     of condition handling occurring."     of condition handling occurring."
246    (kernel:infinite-error-protect    (kernel:infinite-error-protect
247      (with-simple-restart (continue "Return from BREAK.")      (with-simple-restart (continue (intl:gettext "Return from BREAK."))
248        (let ((debug:*stack-top-hint*        (let ((debug:*stack-top-hint*
249               (or debug:*stack-top-hint*               (or debug:*stack-top-hint*
250                   (nth-value 1 (kernel:find-caller-name)))))                   (nth-value 1 (kernel:find-caller-name)))))
# Line 240  Line 259 
259    (kernel:infinite-error-protect    (kernel:infinite-error-protect
260      (let ((condition (coerce-to-condition datum arguments      (let ((condition (coerce-to-condition datum arguments
261                                            'simple-warning 'warn)))                                            'simple-warning 'warn)))
262        (check-type condition warning "a warning condition")        (check-type condition warning (intl:gettext "a warning condition"))
263        (restart-case (signal condition)        (restart-case (signal condition)
264          (muffle-warning ()          (muffle-warning ()
265            :report "Skip warning."            :report (lambda (stream)
266                        (write-string (intl:gettext "Skip warning.") stream))
267            (return-from warn nil)))            (return-from warn nil)))
268        (format *error-output* "~&~@<Warning:  ~3i~:_~A~:>~%" condition)))        (format *error-output* (intl:gettext "~&~@<Warning:  ~3i~:_~A~:>~%") condition)))
269    nil)    nil)
270    
271    ;;; Utility functions
272    
273    (defun simple-program-error (datum &rest arguments)
274      "Invokes the signal facility on a condition formed from datum and arguments.
275       If the condition is not handled, the debugger is invoked.  This function
276       is just like error, except that the condition type defaults to the type
277       simple-program-error, instead of program-error."
278      (kernel:infinite-error-protect
279        (let ((condition (coerce-to-condition datum arguments
280                                              'simple-program-error
281                                              'simple-program-error))
282              (debug:*stack-top-hint* debug:*stack-top-hint*))
283          (unless (and (condition-function-name condition) debug:*stack-top-hint*)
284            (multiple-value-bind
285                (name frame)
286                (kernel:find-caller-name)
287              (unless (condition-function-name condition)
288                (setf (condition-function-name condition) name))
289              (unless debug:*stack-top-hint*
290                (setf debug:*stack-top-hint* frame))))
291          (let ((debug:*stack-top-hint* nil))
292            (signal condition))
293          (invoke-debugger condition))))
294    
295  (in-package "LISP")  (in-package "LISP")
296    
297    
# Line 295  Line 339 
339    #-gengc (setf unix::*interrupt-pending* nil)    #-gengc (setf unix::*interrupt-pending* nil)
340    (setf *type-system-initialized* nil)    (setf *type-system-initialized* nil)
341    (setf *break-on-signals* nil)    (setf *break-on-signals* nil)
342      (setf unix::*filename-encoding* nil)
343    #+gengc (setf conditions::*handler-clusters* nil)    #+gengc (setf conditions::*handler-clusters* nil)
344      (setq intl::*default-domain* "cmucl")
345      (setq intl::*locale* "C")
346    
347    ;; Many top-level forms call INFO, (SETF INFO).    ;; Many top-level forms call INFO, (SETF INFO).
348    (print-and-call c::globaldb-init)    (print-and-call c::globaldb-init)
# Line 306  Line 353 
353    ;; Some of the random top-level forms call Make-Array, which calls Subtypep    ;; Some of the random top-level forms call Make-Array, which calls Subtypep
354    (print-and-call typedef-init)    (print-and-call typedef-init)
355    (print-and-call class-init)    (print-and-call class-init)
356    
357    (print-and-call type-init)    (print-and-call type-init)
358    
359    (let ((funs (nreverse *lisp-initialization-functions*)))    (let ((funs (nreverse *lisp-initialization-functions*)))
360      (%primitive print "Calling top-level forms.")      (%primitive print "Calling top-level forms.")
361      (dolist (fun funs) #+nil (%primitive print (hexstr fun))      #+nil (%primitive print (length funs))
362        (dolist (fun funs)
363          #+nil (%primitive print fun)
364        (typecase fun        (typecase fun
365          (function          (function
366           (funcall fun))           (funcall fun))
# Line 321  Line 371 
371                    (funcall (second fun))))                    (funcall (second fun))))
372             (:load-time-value-fixup             (:load-time-value-fixup
373              #-gengc              #-gengc
374              (setf (sap-ref-32 (second fun) 0)              (setf (#+amd64 sap-ref-64
375                       #-amd64 sap-ref-32 (second fun) 0)
376                    (get-lisp-obj-address                    (get-lisp-obj-address
377                     (svref *load-time-values* (third fun))))                     (svref *load-time-values* (third fun))))
378              #+gengc              #+gengc
379              (do-load-time-value-fixup (second fun) (third fun) (fourth fun)))              (do-load-time-value-fixup (second fun) (third fun) (fourth fun)))
380             #+(and x86 gencgc)             #+(and (or x86 amd64) gencgc)
381             (:load-time-code-fixup             (:load-time-code-fixup
382              (vm::do-load-time-code-fixup (second fun) (third fun) (fourth fun)              (vm::do-load-time-code-fixup (second fun) (third fun) (fourth fun)
383                                           (fifth fun)))                                           (fifth fun)))
# Line 358  Line 409 
409    (print-and-call kernel::signal-init)    (print-and-call kernel::signal-init)
410    (setf (alien:extern-alien "internal_errors_enabled" boolean) t)    (setf (alien:extern-alien "internal_errors_enabled" boolean) t)
411    
412    (set-floating-point-modes :traps '(:overflow #-x86 :underflow :invalid    (set-floating-point-modes :traps '(:overflow :invalid :divide-by-zero))
413                                                 :divide-by-zero))  
414    ;; This is necessary because some of the initial top level forms might    ;; This is necessary because some of the initial top level forms might
415    ;; have changed the compliation policy in strange ways.    ;; have changed the compilation policy in strange ways.
416    (print-and-call c::proclaim-init)    (print-and-call c::proclaim-init)
417    
418    (print-and-call kernel::class-finalize)    (print-and-call kernel::class-finalize)
419    
420      (setq intl::*default-domain* nil)
421    (%primitive print "Done initializing.")    (%primitive print "Done initializing.")
422    
423    #-gengc (setf *already-maybe-gcing* nil)    #-gengc (setf *already-maybe-gcing* nil)
# Line 377  Line 429 
429    (terpri)    (terpri)
430    (princ "[You are in the LISP package.]")    (princ "[You are in the LISP package.]")
431    (terpri)    (terpri)
432    (let ((wot    (let ((wot (catch '%end-of-the-world
433           (catch '%end-of-the-world                 (loop
434             (loop                   (%top-level)
435               (%top-level)                   (write-line "You're certainly a clever child.")))))
              (write-line "You're certainly a clever child.")))))  
436      (unix:unix-exit wot)))      (unix:unix-exit wot)))
437    
438  #+gengc  #+gengc
# Line 425  Line 476 
476      (gc-init)      (gc-init)
477      (setf (alien:extern-alien "internal_errors_enabled" boolean) t)      (setf (alien:extern-alien "internal_errors_enabled" boolean) t)
478      (set-floating-point-modes :traps      (set-floating-point-modes :traps
479                                '(:overflow #-x86 :underflow :invalid                                '(:overflow :invalid :divide-by-zero))
                                           :divide-by-zero))  
480      ;; Clear pseudo atomic in case this core wasn't compiled with support.      ;; Clear pseudo atomic in case this core wasn't compiled with support.
481      #+x86 (setf lisp::*pseudo-atomic-atomic* 0))))      #+(or x86 amd64) (setf lisp::*pseudo-atomic-atomic* 0))))
482    
483    
484  ;;;; Miscellaneous external functions:  ;;;; Miscellaneous external functions:
# Line 450  Line 500 
500    
501  #-mp ; Multi-processing version defined in multi-proc.lisp.  #-mp ; Multi-processing version defined in multi-proc.lisp.
502  (defun sleep (n)  (defun sleep (n)
503    "This function causes execution to be suspended for N seconds.  N may    _N"This function causes execution to be suspended for N seconds.  N may
504    be any non-negative, non-complex number."    be any non-negative, non-complex number."
505    (when (or (not (realp n))    (when (or (not (realp n))
506              (minusp n))              (minusp n))
507      (error "Invalid argument to SLEEP: ~S.~%~      (error 'simple-type-error
508               :format-control
509               "Invalid argument to SLEEP: ~S.~%~
510              Must be a non-negative, non-complex number."              Must be a non-negative, non-complex number."
511             n))             :format-arguments (list n)
512               :datum n
513               :expected-type '(real 0)))
514    (multiple-value-bind (sec usec)    (multiple-value-bind (sec usec)
515      (if (integerp n)      (if (integerp n)
516          (values n 0)          (values n 0)
# Line 467  Line 521 
521    
522  ;;;; SCRUB-CONTROL-STACK  ;;;; SCRUB-CONTROL-STACK
523    
524    #+stack-checking
525    (alien:def-alien-routine "os_guard_control_stack" c-call:void
526      (zone   c-call:int)
527      (guardp c-call:int))
528    
529    
530  (defconstant bytes-per-scrub-unit 2048)  (defconstant bytes-per-scrub-unit 2048)
531    
532  ;;; Scrub-control-stack.  ;;; Scrub-control-stack.
533  ;;;  ;;;
534  #-x86  #-(or x86 amd64)
535  (defun scrub-control-stack ()  (defun %scrub-control-stack ()
536    "Zero the unused portion of the control stack so that old objects are not    _N"Zero the unused portion of the control stack so that old objects are not
537     kept alive because of uninitialized stack variables."     kept alive because of uninitialized stack variables."
538    (declare (optimize (speed 3) (safety 0))    (declare (optimize (speed 3) (safety 0))
539             (values (unsigned-byte 20)))             (values (unsigned-byte 20)))
# Line 509  Line 568 
568    
569  ;;; Scrub-control-stack.  ;;; Scrub-control-stack.
570  ;;;  ;;;
571  ;;; On the x86 port the stack grows downwards, and to support grow on  ;;; On the x86 and amd64 port the stack grows downwards, and to support grow on
572  ;;; demand stacks the stack must be decreased as it is scrubbed.  ;;; demand stacks the stack must be decreased as it is scrubbed.
573  ;;;  ;;;
 #+x86  
574  (defun scrub-control-stack ()  (defun scrub-control-stack ()
575    "Zero the unused portion of the control stack so that old objects are not    "Zero the unused portion of the control stack so that old objects are not
576     kept alive because of uninitialized stack variables."     kept alive because of uninitialized stack variables."
577    (scrub-control-stack))    ;;
578      ;; The guard zone of the control stack is used by Lisp sometimes,
579      ;; so I think it should be zero'd out, too.
580      #+stack-checking (os-guard-control-stack 0 0)
581      (%scrub-control-stack)
582      #+stack-checking (os-guard-control-stack 0 1))
583    
584    #+(or x86 amd64)
585    (defun %scrub-control-stack ()
586      (%scrub-control-stack))
587    
588    
589  ;;;; TOP-LEVEL loop.  ;;;; TOP-LEVEL loop.
# Line 542  Line 609 
609  (defun interactive-eval (form)  (defun interactive-eval (form)
610    "Evaluate FORM, returning whatever it returns but adjust ***, **, *, +++, ++,    "Evaluate FORM, returning whatever it returns but adjust ***, **, *, +++, ++,
611    +, ///, //, /, and -."    +, ///, //, /, and -."
612      (when (and (fboundp 'commandp) (funcall 'commandp form))
613        (return-from interactive-eval (funcall 'invoke-command-interactive form)))
614    (setf - form)    (setf - form)
615    (let ((results (multiple-value-list    (let ((results (multiple-value-list (eval form))))
                   (if (and (fboundp 'commandp)(funcall 'commandp form))  
                       (funcall 'invoke-command-interactive form)  
                       (eval form)))))  
616      (finish-standard-output-streams)      (finish-standard-output-streams)
617      (setf /// //      (setf /// //
618            // /            // /
# Line 560  Line 626 
626    (unless (boundp '*)    (unless (boundp '*)
627      ;; The bogon returned an unbound marker.      ;; The bogon returned an unbound marker.
628      (setf * nil)      (setf * nil)
629      (cerror "Go on with * set to NIL."      (cerror (intl:gettext "Go on with * set to NIL.")
630              "EVAL returned an unbound marker."))              (intl:gettext "EVAL returned an unbound marker.")))
631    (values-list /))    (values-list /))
632    
633    
634  (defconstant eofs-before-quit 10)  (defconstant eofs-before-quit 10)
635    
636    (defparameter *reserved-heap-pages* 256
637      "How many pages to reserve from the total heap space so we can handle
638    heap overflow.")
639    
640    #+heap-overflow-check
641    (alien:def-alien-variable "reserved_heap_pages" c-call:unsigned-long)
642    
643  (defun %top-level ()  (defun %top-level ()
644    "Top-level READ-EVAL-PRINT loop.  Do not call this."    "Top-level READ-EVAL-PRINT loop.  Do not call this."
645    (let  ((* nil) (** nil) (*** nil)    (let  ((* nil) (** nil) (*** nil)
# Line 575  Line 648 
648           (magic-eof-cookie (cons :eof nil))           (magic-eof-cookie (cons :eof nil))
649           (number-of-eofs 0))           (number-of-eofs 0))
650      (loop      (loop
651        (with-simple-restart (abort "Return to Top-Level.")        (with-simple-restart (abort (intl:gettext "Return to Top-Level."))
652          (catch 'top-level-catcher          (catch 'top-level-catcher
653            (unix:unix-sigsetmask 0)            (unix:unix-sigsetmask 0)
654            (let ((*in-top-level-catcher* t))            (let ((*in-top-level-catcher* t))
655              (loop              (loop
656                (scrub-control-stack)                (scrub-control-stack)
657                (fresh-line)                (fresh-line)
658                  ;; Reset reserved pages in the heap
659                  #+heap-overflow-check (setf reserved-heap-pages *reserved-heap-pages*)
660                (princ (if (functionp *prompt*)                (princ (if (functionp *prompt*)
661                           (funcall *prompt*)                           (funcall *prompt*)
662                           *prompt*))                           *prompt*))
# Line 600  Line 675 
675                             (let ((stream (make-synonym-stream '*terminal-io*)))                             (let ((stream (make-synonym-stream '*terminal-io*)))
676                               (setf *standard-input* stream)                               (setf *standard-input* stream)
677                               (setf *standard-output* stream)                               (setf *standard-output* stream)
678                               (format t "~&Received EOF on *standard-input*, ~                               (format t (intl:gettext "~&Received EOF on *standard-input*, ~
679                                          switching to *terminal-io*.~%"))))                                          switching to *terminal-io*.~%")))))
680                        ((> number-of-eofs eofs-before-quit)                        ((> number-of-eofs eofs-before-quit)
681                         (format t "~&Received more than ~D EOFs; Aborting.~%"                         (format t (intl:gettext "~&Received more than ~D EOFs; Aborting.~%")
682                                 eofs-before-quit)                                 eofs-before-quit)
683                         (quit))                         (quit))
684                        (t                        (t
685                         (format t "~&Received EOF.~%")))))))))))                         (format t (intl:gettext "~&Received EOF.~%"))))))))))))
686    
687    
688  ;;; %Halt  --  Interface  ;;; %Halt  --  Interface

Legend:
Removed from v.1.49.2.6  
changed lines
  Added in v.1.82

  ViewVC Help
Powered by ViewVC 1.1.5