Skip to content
Snippets Groups Projects
Commit b4769773 authored by wlott's avatar wlott
Browse files

Added stuff to allow compile-file and compile-from-stream to be used to

compile dylan code.  (Assuming you have the dylan to common-lisp converter
loaded.)
parent 49d1ac4a
No related branches found
No related tags found
No related merge requests found
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/main.lisp,v 1.87 1993/05/15 18:27:03 ram Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/main.lisp,v 1.88 1993/07/22 08:42:43 wlott Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -623,8 +623,10 @@ ...@@ -623,8 +623,10 @@
;; positions that reading of each form started at (i.e. the end of the ;; positions that reading of each form started at (i.e. the end of the
;; previous form.) ;; previous form.)
(forms (make-array 10 :fill-pointer 0 :adjustable t) :type (vector t)) (forms (make-array 10 :fill-pointer 0 :adjustable t) :type (vector t))
(positions (make-array 10 :fill-pointer 0 :adjustable t) :type (vector t))) (positions (make-array 10 :fill-pointer 0 :adjustable t) :type (vector t))
;;
;; Language to use. Normally Lisp, but sometimes Dylan.
(language :lisp :type (member :lisp :dylan)))
;;; The Source-Info structure provides a handle on all the source information ;;; The Source-Info structure provides a handle on all the source information
;;; for an entire compilation. ;;; for an entire compilation.
...@@ -659,7 +661,12 @@ ...@@ -659,7 +661,12 @@
(mapcar #'(lambda (x) (mapcar #'(lambda (x)
(make-file-info :name (namestring (truename x)) (make-file-info :name (namestring (truename x))
:untruename (namestring x) :untruename (namestring x)
:write-date (file-write-date x))) :write-date (file-write-date x)
:language
(if (string-equal (pathname-type x)
"dylan")
:dylan
:lisp)))
files))) files)))
(make-source-info :files file-info (make-source-info :files file-info
...@@ -683,8 +690,9 @@ ...@@ -683,8 +690,9 @@
;;; ;;;
;;; Return a SOURCE-INFO which will read from Stream. ;;; Return a SOURCE-INFO which will read from Stream.
;;; ;;;
(defun make-stream-source-info (stream) (defun make-stream-source-info (stream language)
(let ((files (list (make-file-info :name :stream)))) (declare (type (member :lisp :dylan) language))
(let ((files (list (make-file-info :name :stream :language language))))
(make-source-info (make-source-info
:files files :files files
:current-file files :current-file files
...@@ -725,12 +733,14 @@ ...@@ -725,12 +733,14 @@
;;; *Read-Suppress* on, discarding the result. If an error happens during this ;;; *Read-Suppress* on, discarding the result. If an error happens during this
;;; read, then bail out using Compiler-Error (fatal in this context). ;;; read, then bail out using Compiler-Error (fatal in this context).
;;; ;;;
(defun ignore-error-form (stream pos) (defun ignore-error-form (stream pos language)
(declare (type stream stream) (type unsigned-byte pos)) (declare (type stream stream) (type unsigned-byte pos))
(file-position stream pos) (file-position stream pos)
(handler-case (let ((*read-suppress* t) (handler-case (let ((*read-suppress* t)
(*features* (backend-features *target-backend*))) (*features* (backend-features *target-backend*)))
(read stream)) (ecase language
(:lisp (read stream))
(:dylan (dylan::dylan-read stream))))
(error (condition) (error (condition)
(declare (ignore condition)) (declare (ignore condition))
(compiler-error "Unable to recover from read error.")))) (compiler-error "Unable to recover from read error."))))
...@@ -768,16 +778,19 @@ ...@@ -768,16 +778,19 @@
;;; Read a form from Stream, returning EOF at EOF. If a read error happens, ;;; Read a form from Stream, returning EOF at EOF. If a read error happens,
;;; then attempt to recover if possible, returing a proxy error form. ;;; then attempt to recover if possible, returing a proxy error form.
;;; ;;;
(defun careful-read (stream eof pos) (defun careful-read (stream eof pos language)
(handler-case (let ((*features* (backend-features *target-backend*))) (handler-case (let ((*features* (backend-features *target-backend*)))
(read stream nil eof)) (ecase language
(:lisp (read stream nil eof))
(:dylan
(dylan::dylan-read stream nil eof))))
(error (condition) (error (condition)
(let ((new-pos (file-position stream))) (let ((new-pos (file-position stream)))
(cond ((= new-pos (file-length stream)) (cond ((= new-pos (file-length stream))
(unexpected-eof-error stream pos condition)) (unexpected-eof-error stream pos condition))
(t (t
(normal-read-error stream pos condition) (normal-read-error stream pos condition)
(ignore-error-form stream pos)))) (ignore-error-form stream pos language))))
'(cerror "Skip this form." '(cerror "Skip this form."
"Attempt to load a file having a compile-time read error.")))) "Attempt to load a file having a compile-time read error."))))
...@@ -802,7 +815,8 @@ ...@@ -802,7 +815,8 @@
(setq *compile-file-truename* (pathname name)) (setq *compile-file-truename* (pathname name))
(setq *compile-file-pathname* (setq *compile-file-pathname*
(pathname (file-info-untruename finfo))) (pathname (file-info-untruename finfo)))
(setf (source-info-stream info) (open name :direction :input)))))) (setf (source-info-stream info)
(open name :direction :input))))))
;;; CLOSE-SOURCE-INFO -- Internal ;;; CLOSE-SOURCE-INFO -- Internal
;;; ;;;
...@@ -848,16 +862,20 @@ ...@@ -848,16 +862,20 @@
(let ((eof '(*eof*))) (let ((eof '(*eof*)))
(loop (loop
(let* ((file (first (source-info-current-file info))) (let* ((file (first (source-info-current-file info)))
(language (file-info-language file))
(stream (get-source-stream info)) (stream (get-source-stream info))
(pos (file-position stream)) (pos (file-position stream))
(res (careful-read stream eof pos))) (res (careful-read stream eof pos language)))
(unless (eq res eof) (unless (eq res eof)
(let* ((forms (file-info-forms file)) (let ((form (ecase language
(current-idx (+ (fill-pointer forms) (:dylan (dylan::convert-top-level res))
(file-info-source-root file)))) (:lisp res))))
(vector-push-extend res forms) (let* ((forms (file-info-forms file))
(vector-push-extend pos (file-info-positions file)) (current-idx (+ (fill-pointer forms)
(return (values res current-idx nil)))) (file-info-source-root file))))
(vector-push-extend form forms)
(vector-push-extend pos (file-info-positions file))
(return (values form current-idx nil)))))
(unless (advance-source-file info) (unless (advance-source-file info)
(return (values nil nil t))))))) (return (values nil nil t)))))))
...@@ -1521,7 +1539,8 @@ ...@@ -1521,7 +1539,8 @@
((:block-compile *block-compile*) *block-compile-default*) ((:block-compile *block-compile*) *block-compile-default*)
((:entry-points *entry-points*) nil) ((:entry-points *entry-points*) nil)
((:byte-compile *byte-compile*) *byte-compile-default*) ((:byte-compile *byte-compile*) *byte-compile-default*)
source-info) source-info
(language :lisp))
"Similar to COMPILE-FILE, but compiles text from Stream into the current lisp "Similar to COMPILE-FILE, but compiles text from Stream into the current lisp
environment. Stream is closed when compilation is complete. These keywords environment. Stream is closed when compilation is complete. These keywords
are supported: are supported:
...@@ -1536,9 +1555,11 @@ ...@@ -1536,9 +1555,11 @@
:Source-Info :Source-Info
Some object to be placed in the DEBUG-SOURCE-INFO. Some object to be placed in the DEBUG-SOURCE-INFO.
:Byte-Compile {T, NIL, :MAYBE} :Byte-Compile {T, NIL, :MAYBE}
If true, then may compile to interpreted byte code." If true, then may compile to interpreted byte code.
:Language {:LISP, :DYLAN}
(let ((info (make-stream-source-info stream)) The source language to compile. Defaults to LISP."
(declare (type (member :lisp :dylan) language))
(let ((info (make-stream-source-info stream language))
(*backend* *native-backend*)) (*backend* *native-backend*))
(unwind-protect (unwind-protect
(let* ((*compile-object* (make-core-object)) (let* ((*compile-object* (make-core-object))
......
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