/[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.79.14.1 by rtoy, Thu Feb 25 20:34:50 2010 UTC revision 1.82 by rtoy, Tue Apr 20 17:57:44 2010 UTC
# Line 21  Line 21 
21            ++ +++ ** *** // ///))            ++ +++ ** *** // ///))
22    
23  (defvar *features* '(:common :common-lisp :ansi-cl :ieee-floating-point :cmu)  (defvar *features* '(:common :common-lisp :ansi-cl :ieee-floating-point :cmu)
24    _N"Holds a list of symbols that describe features provided by the    "Holds a list of symbols that describe features provided by the
25     implementation.")     implementation.")
26    
27    
# Line 29  Line 29 
29  (export '(compiler-version scrub-control-stack *runtime-features*))  (export '(compiler-version scrub-control-stack *runtime-features*))
30    
31  (defvar *runtime-features* nil  (defvar *runtime-features* nil
32    _N"Features affecting the runtime")    "Features affecting the runtime")
33    
34  (in-package :extensions)  (in-package :extensions)
35  (export '(quit *prompt*))  (export '(quit *prompt*))
# Line 48  Line 48 
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
51    _N"The fixnum closest in value to positive infinity.")    "The fixnum closest in value to positive infinity.")
52    
53  (defconstant most-negative-fixnum #.vm:target-most-negative-fixnum  (defconstant most-negative-fixnum #.vm:target-most-negative-fixnum
54    _N"The fixnum closest in value to negative infinity.")    "The fixnum closest in value to negative infinity.")
55    
56    
57  ;;; Random information:  ;;; Random information:
# Line 142  Line 142 
142  (in-package "CONDITIONS")  (in-package "CONDITIONS")
143    
144  (defvar *break-on-signals* nil  (defvar *break-on-signals* nil
145    _N"When (typep condition *break-on-signals*) is true, then calls to SIGNAL will    "When (typep condition *break-on-signals*) is true, then calls to SIGNAL will
146     enter the debugger prior to signalling that condition.")     enter the debugger prior to signalling that condition.")
147    
148  (defun signal (datum &rest arguments)  (defun signal (datum &rest arguments)
149    _N"Invokes the signal facility on a condition formed from datum and arguments.    "Invokes the signal facility on a condition formed from datum and arguments.
150     If the condition is not handled, nil is returned.  If     If the condition is not handled, nil is returned.  If
151     (TYPEP condition *BREAK-ON-SIGNALS*) is true, the debugger is invoked before     (TYPEP condition *BREAK-ON-SIGNALS*) is true, the debugger is invoked before
152     any signalling is done."     any signalling is done."
# Line 156  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 173  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 191  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)
198    _N"Invokes the signal facility on a condition formed from datum and arguments.    "Invokes the signal facility on a condition formed from datum and arguments.
199     If the condition is not handled, the debugger is invoked."     If the condition is not handled, the debugger is invoked."
200    (kernel:infinite-error-protect    (kernel:infinite-error-protect
201      (let ((condition (coerce-to-condition datum arguments      (let ((condition (coerce-to-condition datum arguments
# Line 241  Line 241 
241    nil)    nil)
242    
243  (defun break (&optional (datum "Break") &rest arguments)  (defun break (&optional (datum "Break") &rest arguments)
244    _N"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 253  Line 253 
253    nil)    nil)
254    
255  (defun warn (datum &rest arguments)  (defun warn (datum &rest arguments)
256    _N"Warns about a situation by signalling a condition formed by datum and    "Warns about a situation by signalling a condition formed by datum and
257     arguments.  While the condition is being signaled, a muffle-warning restart     arguments.  While the condition is being signaled, a muffle-warning restart
258     exists that causes WARN to immediately return nil."     exists that causes WARN to immediately return nil."
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 (lambda (condition stream)            :report (lambda (stream)
266                      (declare (ignore condition))                      (write-string (intl:gettext "Skip warning.") stream))
                     (write-string _"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  ;;; Utility functions
272    
273  (defun simple-program-error (datum &rest arguments)  (defun simple-program-error (datum &rest arguments)
274    _N"Invokes the signal facility on a condition formed from datum and arguments.    "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     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     is just like error, except that the condition type defaults to the type
277     simple-program-error, instead of program-error."     simple-program-error, instead of program-error."
# Line 328  Line 327 
327      str))      str))
328    
329  (defun %initial-function ()  (defun %initial-function ()
330    _N"Gives the world a shove and hopes it spins."    "Gives the world a shove and hopes it spins."
331    (%primitive print "In initial-function, and running.")    (%primitive print "In initial-function, and running.")
332    #-gengc (setf *already-maybe-gcing* t)    #-gengc (setf *already-maybe-gcing* t)
333    #-gengc (setf *gc-inhibit* t)    #-gengc (setf *gc-inhibit* t)
# Line 485  Line 484 
484  ;;;; Miscellaneous external functions:  ;;;; Miscellaneous external functions:
485    
486  (defvar *cleanup-functions* nil  (defvar *cleanup-functions* nil
487    _N"Functions to be invoked during cleanup at Lisp exit.")    "Functions to be invoked during cleanup at Lisp exit.")
488    
489  ;;; Quit gets us out, one way or another.  ;;; Quit gets us out, one way or another.
490    
491  (defun quit (&optional recklessly-p)  (defun quit (&optional recklessly-p)
492    _N"Terminates the current Lisp.  Things are cleaned up unless Recklessly-P is    "Terminates the current Lisp.  Things are cleaned up unless Recklessly-P is
493    non-Nil."    non-Nil."
494    (if recklessly-p    (if recklessly-p
495        (unix:unix-exit 0)        (unix:unix-exit 0)
# Line 573  Line 572 
572  ;;; demand stacks the stack must be decreased as it is scrubbed.  ;;; demand stacks the stack must be decreased as it is scrubbed.
573  ;;;  ;;;
574  (defun scrub-control-stack ()  (defun scrub-control-stack ()
575    _N"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    ;;    ;;
578    ;; The guard zone of the control stack is used by Lisp sometimes,    ;; The guard zone of the control stack is used by Lisp sometimes,
# Line 590  Line 589 
589  ;;;; TOP-LEVEL loop.  ;;;; TOP-LEVEL loop.
590    
591  (defvar / nil  (defvar / nil
592    _N"Holds a list of all the values returned by the most recent top-level EVAL.")    "Holds a list of all the values returned by the most recent top-level EVAL.")
593  (defvar // nil _N"Gets the previous value of / when a new value is computed.")  (defvar // nil "Gets the previous value of / when a new value is computed.")
594  (defvar /// nil _N"Gets the previous value of // when a new value is computed.")  (defvar /// nil "Gets the previous value of // when a new value is computed.")
595  (defvar * nil _N"Holds the value of the most recent top-level EVAL.")  (defvar * nil "Holds the value of the most recent top-level EVAL.")
596  (defvar ** nil _N"Gets the previous value of * when a new value is computed.")  (defvar ** nil "Gets the previous value of * when a new value is computed.")
597  (defvar *** nil _N"Gets the previous value of ** when a new value is computed.")  (defvar *** nil "Gets the previous value of ** when a new value is computed.")
598  (defvar + nil _N"Holds the value of the most recent top-level READ.")  (defvar + nil "Holds the value of the most recent top-level READ.")
599  (defvar ++ nil _N"Gets the previous value of + when a new value is read.")  (defvar ++ nil "Gets the previous value of + when a new value is read.")
600  (defvar +++ nil _N"Gets the previous value of ++ when a new value is read.")  (defvar +++ nil "Gets the previous value of ++ when a new value is read.")
601  (defvar - nil _N"Holds the form curently being evaluated.")  (defvar - nil "Holds the form curently being evaluated.")
602  (defvar *prompt* "* "  (defvar *prompt* "* "
603    _N"The top-level prompt string.  This also may be a function of no arguments    "The top-level prompt string.  This also may be a function of no arguments
604     that returns a simple-string.")     that returns a simple-string.")
605  (defvar *in-top-level-catcher* nil  (defvar *in-top-level-catcher* nil
606    _N"True if we are within the Top-Level-Catcher.  This is used by interrupt    "True if we are within the Top-Level-Catcher.  This is used by interrupt
607    handlers to see whether it is o.k. to throw.")    handlers to see whether it is o.k. to throw.")
608    
609  (defun interactive-eval (form)  (defun interactive-eval (form)
610    _N"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))    (when (and (fboundp 'commandp) (funcall 'commandp form))
613      (return-from interactive-eval (funcall 'invoke-command-interactive form)))      (return-from interactive-eval (funcall 'invoke-command-interactive form)))
# Line 627  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  (defparameter *reserved-heap-pages* 256
637    _N"How many pages to reserve from the total heap space so we can handle    "How many pages to reserve from the total heap space so we can handle
638  heap overflow.")  heap overflow.")
639    
640  #+heap-overflow-check  #+heap-overflow-check
641  (alien:def-alien-variable "reserved_heap_pages" c-call:unsigned-long)  (alien:def-alien-variable "reserved_heap_pages" c-call:unsigned-long)
642    
643  (defun %top-level ()  (defun %top-level ()
644    _N"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)
646           (- nil) (+ nil) (++ nil) (+++ nil)           (- nil) (+ nil) (++ nil) (+++ nil)
647           (/// nil) (// nil) (/ nil)           (/// nil) (// nil) (/ nil)
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))
# Line 676  heap overflow.") Line 675  heap overflow.")
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.79.14.1  
changed lines
  Added in v.1.82

  ViewVC Help
Powered by ViewVC 1.1.5