/[gcl]/gcl/lsp/gcl_top.lsp
ViewVC logotype

Diff of /gcl/lsp/gcl_top.lsp

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

revision 1.5 by camm, Sun Apr 10 01:13:36 2005 UTC revision 1.6 by camm, Fri Jun 10 15:31:55 2005 UTC
# Line 113  Line 113 
113                (setq - (locally (declare (notinline read))                (setq - (locally (declare (notinline read))
114                                 (read *standard-input* nil *top-eof*)))                                 (read *standard-input* nil *top-eof*)))
115                (when (eq - *top-eof*) (bye))                (when (eq - *top-eof*) (bye))
116    ;              (si::clear-c-stack 4096)
117                (let ((values (multiple-value-list                (let ((values (multiple-value-list
118                               (locally (declare (notinline eval)) (eval -)))))                               (locally (declare (notinline eval)) (eval -)))))
119                  (setq /// // // / / values *** ** ** * * (car /))                  (setq /// // // / / values *** ** ** * * (car /))
# Line 151  Line 152 
152           ((eq ch eof-value) (return-from dbl-read eof-value)))           ((eq ch eof-value) (return-from dbl-read eof-value)))
153     (unread-char ch stream))     (unread-char ch stream))
154    
155    (cond ((eql #\: ch)    (cond
156           (setq tem  ;   ((eql #\: ch)
157                 (string-concatenate  ;    (setq tem
158                  "("  ;         (string-concatenate
159                  (read-line stream eof-error-p eof-value)")"))  ;          "("
160           (read  (make-string-input-stream tem)  ;          (read-line stream eof-error-p eof-value)")"))
161                                           eof-error-p eof-value))  ;    (read  (make-string-input-stream tem)
162    ;          eof-error-p eof-value))
163          (t (read stream eof-error-p eof-value))))          (t (read stream eof-error-p eof-value))))
164    
165    
166  (defun break-level (at &optional env)  (defun break-level (at &optional env)
167    (let* ((*break-message* (if (stringp at) at *break-message*))    (let* ((*break-message* (if (stringp at) at *break-message*))
168           (*quit-tags* (cons (cons *break-level* *quit-tag*) *quit-tags*))           (quit-tags1 (cons *break-level* *quit-tag*))
169           (*quit-tag* (cons nil nil))           (quit-tags (cons quit-tags1 *quit-tags*))
170           (*break-level* (if (not at) *break-level* (cons t *break-level*)))           (*quit-tags* quit-tags)
171             (quit-tag (cons nil nil))
172             (*quit-tag* quit-tag)
173             (break-level (cons t *break-level*))
174             (*break-level* (if (not at) *break-level* break-level))
175           (*ihs-base* (1+ *ihs-top*))           (*ihs-base* (1+ *ihs-top*))
176           (*ihs-top* (1- (ihs-top)))           (*ihs-top* (1- (ihs-top)))
177           (*current-ihs* *ihs-top*)           (*current-ihs* *ihs-top*)
# Line 184  Line 190 
190           (* *) (** **) (*** ***)           (* *) (** **) (*** ***)
191           (/ /) (// //) (/// ///)           (/ /) (// //) (/// ///)
192           )           )
193        (declare (:dynamic-extent quit-tags quit-tags1 quit-tag break-level))
194                                          ; (terpri *error-output*)                                          ; (terpri *error-output*)
195      (unless (or be (not (stringp at)))      (unless (or be (not (stringp at)))
196        (simple-backtrace)        (simple-backtrace)
# Line 210  Line 217 
217            (setq - (locally (declare (notinline read))            (setq - (locally (declare (notinline read))
218                             (dbl-read *debug-io* nil *top-eof*)))                             (dbl-read *debug-io* nil *top-eof*)))
219            (when (eq - *top-eof*) (bye -1))            (when (eq - *top-eof*) (bye -1))
220            (let* ( break-command            (let* (break-command
221                   (values                   (values
222                    (multiple-value-list                    (multiple-value-list
223                    (LOCALLY (declare (notinline break-call evalhook))                    (LOCALLY (declare (notinline break-call evalhook))
224                             (if (keywordp -)(setq - (cons - nil)))  ;                          (if (keywordp -)(setq - (cons - nil)))
225                             (cond ((and (consp -) (keywordp (car -)))                             (cond
226                                    (setq break-command t)                              ((keywordp -)
227                                    (break-call (car -) (cdr -) 'si::break-command))                               (setq break-command t)
228                                   (t (evalhook - nil nil *break-env*)))))))                               (break-call - nil 'si::break-command))
229                                ((and (consp -) (keywordp (car -)))
230                                 (setq break-command t)
231                                 (break-call (car -) (cdr -) 'si::break-command))
232                                (t (evalhook - nil nil *break-env*)))))))
233              (and break-command (eq (car values) :resume )(return))              (and break-command (eq (car values) :resume )(return))
234              (setq /// // // / / values *** ** ** * * (car /))              (setq /// // // / / values *** ** ** * * (car /))
235              (fresh-line *debug-io*)              (fresh-line *debug-io*)
# Line 246  Line 257 
257    (error-name correctable function-name    (error-name correctable function-name
258     continue-format-string error-format-string     continue-format-string error-format-string
259     &rest args &aux message)     &rest args &aux message)
260    (declare (ignore error-name))    (declare (ignore error-name) (:dynamic-extent args))
261    (let ((*print-pretty* nil)    (let ((*print-pretty* nil)
262          (*print-level* *debug-print-level*)          (*print-level* *debug-print-level*)
263          (*print-length* *debug-print-level*)          (*print-length* *debug-print-level*)

Legend:
Removed from v.1.5  
changed lines
  Added in v.1.6

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26