[yuasa%tutics.tut.junet%utokyo-relay.csnet@RELAY.CS.NET: Re: uninterned symbols and compiler]

[Robert S. Boyer <boyer@CLI.COM>]

Date: Wed,  7 Sep 88 12:16:48 jst
From: Taiichi Yuasa <yuasa%tutics.tut.junet%utokyo-relay.csnet@RELAY.CS.NET>
To: boyer@CLI.COM
Subject: Re: uninterned symbols and compiler



Dear Prof. Boyer,

Some months ago, you sent me a mail telling that the function COMPILE
in KCL does not take care of functions named by uninterned symbols.
The real problem is that the KCL compiler cannot compile lexical closures
in general.  The function in your mail was such a closure and the compiler
intended to say "I cannot compile it".  That message was quite misleading
and the current compiler meesages are better I think.  Here's the
current code at my hand for the function COMPILE.

(defun compile1 (name &optional (def nil supplied-p)
                      &aux form gazonk-name
                      #+aosvs fasl-pathname
                      #+unix data-pathname
                      (*compiler-in-use* *compiler-in-use*)
                      (*standard-output* *standard-output*)
                      (*error-output* *error-output*)
                      (*package* *package*)
                      (*compile-print* nil)
                      (*error-count* 0))

  (unless (symbolp name) (error "~s is not a symbol." name))

  (cond (*compiler-in-use*
         (format t "~&The compiler was called recursively.~%~
Cannot compile ~s." name)
         (setq *error-p* t)
         (return-from compile1))
        (t (setq *error-p* nil)
           (setq *compiler-in-use* t)))

  (cond ((and supplied-p (not (null def)))
         (unless (and (consp def) (eq (car def) 'lambda))
                 (error "~s is invalid lambda expression." def))
         (setq form (if name
                        `(defun ,name ,@(cdr def))
                        `(set 'gazonk #',def))))
        ((and (fboundp name)
              (consp (setq def (symbol-function name))))
         (cond ((and (eq (car def) 'lambda-block)
                     (consp (cdr def)) (consp (cddr def)))
                (if (eq (cadr def) name)
                    (setq form `(defun ,name ,@(cddr def)))
                    (setq form `(defun ,name ,(caddr def)
                                  (block ,(cadr def) ,@(cdddr def))))))
               ((eq (car def) 'lambda)
                (setq form `(defun ,name ,@(cdr def))))
               ((and (eq (car def) 'lambda-closure)
                     (consp (cdr def)) (null (cadr def))
                     (consp (cddr def)) (null (caddr def))
                     (consp (cdddr def)) (null (cadddr def)))
                (setq form `(defun ,name ,@(cddddr def))))
               ((and (eq (car def) 'lambda-block-closure)
                     (consp (cdr def)) (null (cadr def))
                     (consp (cddr def)) (null (caddr def))
                     (consp (cdddr def)) (null (cadddr def))
                     (consp (cddddr def)))
                (setq form `(defun ,name
                              (block ,(car (cddddr def))
                                ,@(cdr (cddddr def))))))
               (t (error "I cannot compile such ~Ss, sorry." (car def)))))
        (t (error "No lambda expression is assigned to the symbol ~s." name)))


  (dotimes (n 1000
              (progn
                (format t "~&The name space for GAZONK files exhausted.~%~
Delete one of your GAZONK*** files before compiling ~s." name)
                (setq *error-p* t)
                (return-from compile1 (values))))
    (setq gazonk-name (format nil "gazonk~3,'0d" n))
    #+aosvs
    (setq fasl-pathname (make-pathname :name gazonk-name :type "fasl"))
    #+unix
    (setq data-pathname (make-pathname :name gazonk-name :type "data"))
    (unless (probe-file #+aosvs fasl-pathname
                        #+unix data-pathname)
      (return)))

  (let ((c-pathname (make-pathname :name gazonk-name :type "c"))
        #+buggy-cc
        (s-pathname (make-pathname :name gazonk-name :type "s"))
        (h-pathname (make-pathname :name gazonk-name :type "h"))
        #+unix (o-pathname (make-pathname :name gazonk-name :type "o"))
        #+aosvs (ob-pathname (make-pathname :name gazonk-name :type "ob")))

    (init-env)

    (with-open-file (*compiler-output-data*
                     #+unix data-pathname #+aosvs fasl-pathname
                     :direction :output)
      (wt-data-begin)

      (t1expr form)

      (when (zerop *error-count*)
        (when *compile-verbose* (format t "~&End of Pass 1.  "))
        (compiler-pass2 c-pathname h-pathname nil "code"))

      (wt-data-end)
      ) ;;; *compiler-output-data* closed.

    (init-env)

    (if (zerop *error-count*)
        #+aosvs
        (progn
          (when *compile-verbose* (format t "~&End of Pass 2.  "))
          (compiler-cc c-pathname ob-pathname)
          (delete-file c-pathname)
          (delete-file h-pathname)
          (cond ((probe-file ob-pathname)
                 (compiler-build ob-pathname fasl-pathname)
                 (delete-file ob-pathname)
                 (load fasl-pathname :verbose nil)
                 (when *compile-verbose* (print-compiler-info))
                 (delete-file fasl-pathname)
                 (or name (symbol-value 'gazonk)))
                (t (delete-file fasl-pathname)
                   (format t "~&Your C compiler failed to compile the intermediate code for ~s.~%" name)
                   (setq *error-p* t)
                   name)))

        #+unix
        (progn
          (when *compile-verbose* (format t "~&End of Pass 2.  "))
          (compiler-cc c-pathname o-pathname #+buggy-cc s-pathname)
          (delete-file c-pathname)
          (delete-file h-pathname)
          #+buggy-cc (when (probe-file s-pathname) (delete-file s-pathname))
          (cond ((probe-file o-pathname)
                 (compiler-build o-pathname data-pathname)
                 (load o-pathname :verbose nil)
                 (when *compile-verbose* (print-compiler-info))
                 (delete-file o-pathname)
                 (delete-file data-pathname)
                 (or name (symbol-value 'gazonk)))
                (t (delete-file data-pathname)
                   (format t "~&Your C compiler failed to compile the intermediate code for ~s.~%" name)
                   (setq *error-p* t)
                   name)))

        (progn
          (when (probe-file c-pathname) (delete-file c-pathname))
          (when (probe-file h-pathname) (delete-file h-pathname))
          #+aosvs
          (when (probe-file fasl-pathname) (delete-file fasl-pathname))
          #+unix
          (when (probe-file data-pathname) (delete-file data-pathname))
          (format t "~&Failed to compile ~s.~%" name)
          (setq *error-p* t)
          name))))



-- Taiichi