Skip to content
Snippets Groups Projects
Commit 0651a129 authored by ram's avatar ram
Browse files

Changed stuff to correspond to the new interface to IR1-TOP-LEVEL and

FIND-SOURCE-PATHS.  Now we call FIND-SOURCE-PATHS before doing our recursive
PROCESS-FORM walk, and we just pass around the TLF number, instead of
constructing a source path as we go.  This allowed PROCESS-FORM to be changed
to expand macros.
parent 97ca04e3
No related branches found
No related tags found
No related merge requests found
...@@ -656,8 +656,8 @@ ...@@ -656,8 +656,8 @@
;;; Read-Source-Form -- Internal ;;; Read-Source-Form -- Internal
;;; ;;;
;;; Read the next form from the source designated by Info. The second value ;;; Read the next form from the source designated by Info. The second value
;;; is the initial source path for the read form. The third value is true when ;;; is the top-level form number of the read form. The third value is true
;;; at EOF. ;;; when at EOF.
;;; ;;;
;;; We carefully read from the current source file. If it is at EOF, we ;;; We carefully read from the current source file. If it is at EOF, we
;;; advance to the next file and try again. When we get a form, we enter it ;;; advance to the next file and try again. When we get a form, we enter it
...@@ -677,7 +677,7 @@ ...@@ -677,7 +677,7 @@
(file-info-source-root file)))) (file-info-source-root file))))
(vector-push-extend res forms) (vector-push-extend res forms)
(vector-push-extend pos (file-info-positions file)) (vector-push-extend pos (file-info-positions file))
(return (values res (list current-idx) nil)))) (return (values res current-idx nil))))
(unless (advance-source-file info) (unless (advance-source-file info)
(return (values nil nil t))))))) (return (values nil nil t)))))))
...@@ -708,9 +708,9 @@ ...@@ -708,9 +708,9 @@
;;; form, but delay compilation, pushing the result on *TOP-LEVEL-LAMBDAS* ;;; form, but delay compilation, pushing the result on *TOP-LEVEL-LAMBDAS*
;;; instead. ;;; instead.
;;; ;;;
(defun convert-and-maybe-compile (form path object) (defun convert-and-maybe-compile (form tlf-num object)
(declare (list path) (type object object)) (declare (type index tlf-num) (type object object))
(let ((tll (ir1-top-level form path nil))) (let ((tll (ir1-top-level form tlf-num nil)))
(cond (*block-compile* (push tll *top-level-lambdas*)) (cond (*block-compile* (push tll *top-level-lambdas*))
(t (t
(compile-top-level (list tll) object) (compile-top-level (list tll) object)
...@@ -720,17 +720,13 @@ ...@@ -720,17 +720,13 @@
;;; PROCESS-PROGN -- Internal ;;; PROCESS-PROGN -- Internal
;;; ;;;
;;; Process a PROGN-like portion of a top-level form. Forms is a list of ;;; Process a PROGN-like portion of a top-level form. Forms is a list of
;;; the forms, and Path is the source path that lead to the immediately ;;; the forms, and TLF-Num is the top-level form number of the form they came
;;; enclosing form. Offset is added to the position within Forms when ;;; out of.
;;; computing the source path of the subforms.
;;; ;;;
(defun process-progn (forms path offset object) (defun process-progn (forms tlf-num object)
(declare (list forms path) (type unsigned-byte offset) (declare (list forms) (type index tlf-num) (type object object))
(type object object)) (dolist (form forms)
(do ((i offset (1+ i)) (process-form form tlf-num object)))
(form forms (cdr form)))
((endp form))
(process-form (car form) (cons i path) object)))
(proclaim '(special *compiler-error-bailout*)) (proclaim '(special *compiler-error-bailout*))
...@@ -744,18 +740,23 @@ ...@@ -744,18 +740,23 @@
;;; ### At least for now, always dump package frobbing as interpreted cold load ;;; ### At least for now, always dump package frobbing as interpreted cold load
;;; forms. This might want to be on a switch someday. ;;; forms. This might want to be on a switch someday.
;;; ;;;
(defun process-form (form path object) (defun process-form (form tlf-num object)
(declare (list path) (type object object)) (declare (type index tlf-num) (type object object))
(catch 'process-form-error-abort (catch 'process-form-error-abort
(let ((*compiler-error-bailout* (let* ((*compiler-error-bailout*
#'(lambda () #'(lambda ()
(convert-and-maybe-compile (convert-and-maybe-compile
`(error "Execution of a form compiled with errors:~% ~S" `(error "Execution of a form compiled with errors:~% ~S"
',form) ',form)
path object) tlf-num object)
(throw 'process-form-error-abort nil)))) (throw 'process-form-error-abort nil)))
(form
(handler-case (macroexpand form *fenv*)
(error (condition)
(compiler-error "(during macroexpansion)~%~A"
condition)))))
(if (atom form) (if (atom form)
(convert-and-maybe-compile form path object) (convert-and-maybe-compile form tlf-num object)
(case (car form) (case (car form)
((make-package in-package shadow shadowing-import export ((make-package in-package shadow shadowing-import export
unexport use-package unuse-package import) unexport use-package unuse-package import)
...@@ -769,17 +770,17 @@ ...@@ -769,17 +770,17 @@
(do-eval-when-stuff (do-eval-when-stuff
(cadr form) (cddr form) (cadr form) (cddr form)
#'(lambda (forms) #'(lambda (forms)
(process-progn forms path 2 object)))) (process-progn forms tlf-num object))))
((macrolet) ((macrolet)
(unless (>= (length form) 2) (unless (>= (length form) 2)
(compiler-error "MACROLET form is too short: ~S." form)) (compiler-error "MACROLET form is too short: ~S." form))
(do-macrolet-stuff (do-macrolet-stuff
(cadr form) (cadr form)
#'(lambda () #'(lambda ()
(process-progn (cddr form) path 2 object)))) (process-progn (cddr form) tlf-num object))))
(progn (process-progn (cdr form) path 1 object)) (progn (process-progn (cdr form) tlf-num object))
(t (t
(convert-and-maybe-compile form path object)))))) (convert-and-maybe-compile form tlf-num object))))))
(undefined-value)) (undefined-value))
...@@ -822,10 +823,12 @@ ...@@ -822,10 +823,12 @@
(*last-format-args* nil) (*last-format-args* nil)
(*last-message-count* 0)) (*last-message-count* 0))
(loop (loop
(multiple-value-bind (form path eof-p) (multiple-value-bind (form tlf eof-p)
(read-source-form info) (read-source-form info)
(when eof-p (return)) (when eof-p (return))
(process-form form path object))) (clrhash *source-paths*)
(find-source-paths form tlf)
(process-form form tlf object)))
(when *block-compile* (when *block-compile*
(compile-top-level (nreverse *top-level-lambdas*) object) (compile-top-level (nreverse *top-level-lambdas*) object)
...@@ -1066,34 +1069,35 @@ ...@@ -1066,34 +1069,35 @@
(*last-format-string* nil) (*last-format-string* nil)
(*last-format-args* nil) (*last-format-args* nil)
(*last-message-count* 0) (*last-message-count* 0)
(object (make-core-object)) (object (make-core-object)))
(lambda (ir1-top-level form '(0) t))) (find-source-paths form 0)
(let ((lambda (ir1-top-level form 0 t)))
(compile-fix-function-name lambda name)
(let* ((component
(block-component (node-block (lambda-bind lambda))))
(*all-components* (list component)))
(local-call-analyze component))
(let* ((components (find-initial-dfo (list lambda)))
(*all-components* components))
(dolist (component components)
(compile-component component object)
(clear-ir2-info component)))
(fix-core-source-info *source-info* object)
(let* ((res (core-call-top-level-lambda lambda object))
(return (or name res)))
(when name
(setf (fdefinition name) res))
(cond ((or (> *compiler-error-count* start-errors) (compile-fix-function-name lambda name)
(> *compiler-warning-count* start-warnings)) (let* ((component
(values return t t)) (block-component (node-block (lambda-bind lambda))))
((> *compiler-note-count* start-notes) (*all-components* (list component)))
(values return t nil)) (local-call-analyze component))
(t
(values return nil nil))))))))) (let* ((components (find-initial-dfo (list lambda)))
(*all-components* components))
(dolist (component components)
(compile-component component object)
(clear-ir2-info component)))
(fix-core-source-info *source-info* object)
(let* ((res (core-call-top-level-lambda lambda object))
(return (or name res)))
(when name
(setf (fdefinition name) res))
(cond ((or (> *compiler-error-count* start-errors)
(> *compiler-warning-count* start-warnings))
(values return t t))
((> *compiler-note-count* start-notes)
(values return t nil))
(t
(values return nil nil)))))))))
#+new-compiler #+new-compiler
;;; UNCOMPILE -- Public ;;; UNCOMPILE -- Public
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment