src/lsp/compiler/cmpfront.lsp

   1 (in-package "XLISP")
   2
   3 (export '(compile compile-file *compile-verbose* *compile-print*))
   4
   5 (defpackage "XLSCMP"
   6   (:use "XLISP")
   7   (:import-from "XLISP" "*CMP-SETF*" "*CMP-STRUCTS*" "*CMP-GLOBAL-MACROS*"
   8                 "*CMP-MACROS*" "*CMP-SPECIALS*" #+xlisp-stat "ADD-METHOD"))
   9
  10 (in-package "XLSCMP")
  11
  12 #|
  13 put in package stuff
  14 move macros to cmpmacr.lsp
  15 move cps stuff to convert.lsp
  16 |#
  17
  18 (require "backquot")
  19
  20 (require "cmpmacro")
  21 (require "convert")
  22 (require "cells")
  23 (require "simplify")
  24 (require "lift")
  25 (require "gencode")
  26 (require "peephole")
  27 (require "assemble")
  28
  29 #|
  30 Macros currently defined (**** need to be checked over ***):
  31
  32 DEFSETF PUSH PUSHNEW STEP WITH-INPUT-FROM-STRING WITH-OPEN-FILE
  33 WITH-OUTPUT-TO-STRING
  34
  35
  36 Macros needed (check which are really needed):
  37
  38 assert call-method ccase check-type ctypecase decf declaim defclass
  39 defgeneric define-compiler-macro define-condition define-declaration
  40 define-method-combination define-modify-macro define-setf-method
  41 defmethod defpackage deftype destructuring-bind do-all-symbols
  42 do-external-symbols do-symbols ecase encapsulated etypecase formatter
  43 gathering generic-function handler-bind handler-case ignore-errors
  44 in-package incf iterate loop-finish mapping multiple-value-bind
  45 multiple-value-list multiple-value-setq next-in nth-value pop
  46 pprint-exit-if-exhausted pprint-logical-block pprint-pop
  47 print-unreadable-object producing psetf remf restart-bind restart-case
  48 rotatef shiftf terminate-producing typecase with-accessors
  49 with-compilation-unit with-condition-restarts with-hash-table-iterator
  50 with-open-stream with-package-iterator with-simple-restarts with-slots
  51 with-standard-io-syntax
  52 |#
  53
  54 (defun pscvt (e)
  55   (progv '(*cmp-env*   *cmp-fenv*  *cmp-denv*   *cmp-tenv* *cmp-specials*
  56            *cmp-gvars* *cmp-gfuns* *cmp-consts*
  57            *cmp-specials* *cmp-macros* *cmp-setf* *cmp-structs*)
  58          '(nil nil nil nil nil nil nil nil nil nil nil nil)
  59          (let ((n (if (and (consp e) (eq (first e) 'lambda))
  60                       (convert-lambda e)
  61                       (convert-lambda `(lambda () ,e)))))
  62            (pp-cps (merge-tests (simplify-tree (insert-cells n)))))))
  63
  64
  65 ;;;;
  66 ;;;; Simple compiler front end
  67 ;;;;
  68
  69 (defun cmp (e &optional name)
  70   (progv '(*cmp-env* *cmp-denv* *cmp-tenv*
  71            *cmp-gvars* *cmp-gfuns* *cmp-consts*)
  72          '(nil nil nil nil nil nil)
  73          (let ((n (if (and (consp e) (eq (first e) 'lambda))
  74                       (if name
  75                           (convert-named-lambda (cons name (rest e)))
  76                           (convert-lambda e))
  77                       (convert-lambda `(lambda () ,e)))))
  78            (insert-cells n)
  79            (substitute-all-variables n)
  80            (collapse-null-lambda-calls n)
  81            (simplify-tree n)
  82            (merge-tests n)
  83            (let ((pieces (lift-lambdas n)))
  84              (dolist (p pieces)
  85                (let ((c (second p)))
  86                  (extract-constants c)
  87                  (remove-unused-cells c)
  88                  ;;(mapcar #'pp-cps p)
  89                  ))
  90              (generate-code pieces)))))
  91
  92 (defun pcmp (e) (pprint (cmp e)))
  93
  94 (defun cmp-reset ()
  95   (mapcar #'set
  96           '(*cmp-env* *cmp-fenv* *cmp-denv* *cmp-tenv*
  97             *cmp-specials* *cmp-macros* *cmp-setf* *cmp-structs*
  98             *cmp-gvars* *cmp-gfuns* *cmp-consts*)
  99           '(nil nil nil nil nil nil nil nil nil nil nil)))
 100
 101
 102 (defparameter *cmp-files*
 103   '("backquot" "cmpmacro" "convert" "cells" "simplify"
 104     "lift" "gencode" "peephole" "assemble" "cmpfront"))
 105
 106 (defun compile-file-list (list &optional load)
 107   (progv '(*features*)
 108          #+unix '((WINDOWS DIALOGS COLOR UNIX X11 XLISP))
 109          #+macintosh '((WINDOWS DIALOGS MACINTOSH XLISP))
 110          (dolist (f list)
 111            (format t "~%Compiling file ~s ... ~%" f)
 112            (compile-file f)
 113            (format t "finished compiling file ~s~%~%" f)
 114            (if load (load f)))))
 115
 116 (defun compile-cmp () (compile-file-list *cmp-files* t))
 117
 118 ;;;;;
 119 ;;;;;
 120 ;;;;; New File Compiler
 121 ;;;;;
 122 ;;;;;
 123
 124 (defun print-compiled-form (form stream sp)
 125   (let ((*print-readably* t)
 126         (*print-symbol-package* sp))
 127     (format stream "~s~%" form)))
 128
 129 (defun accumulate-compiled-form (form outstuff)
 130   (rplacd (last outstuff) (list form)))
 131
 132 ;;**** change default later?
 133 (defvar *compile-verbose* t)
 134 (defvar *compile-print* t)
 135
 136 (defvar *compile-print-symbol-package* nil)
 137
 138 (defvar *compile-warn-specials* nil)
 139
 140 (defvar *cmp-specials* nil)
 141 (defvar *cmp-macros* nil)
 142 (defvar *cmp-setf* nil)
 143 (defvar *cmp-structs* nil)
 144
 145 #|
 146 (defun file-name-needs-extension (fname)
 147   (not (eql #\.
 148             (find-if-not #'(lambda (x) (or (digit-char-p x) (alpha-char-p x)))
 149                          fname
 150                          :from-end t))))
 151
 152 (defun lsp-file-name (f)
 153   (if (file-name-needs-extension f)
 154       (concatenate 'string f ".lsp")
 155       f))
 156
 157 (defun fsl-file-name (f)
 158   (let ((n (length f)))
 159     (unless (and (<= 4 (length f)) (string= (subseq f (- n 4) n) ".lsp"))
 160             (error "not a valid lisp file name -- ~s" f))
 161     (concatenate 'string (subseq f 0 (- n 4)) ".fsl")))
 162 |#
 163
 164 (defun cmp-print-start-message (form)
 165   (when *compile-print*
 166         (let ((*print-level* 2)
 167               (*print-length* 3))
 168           (format t "~&; compiling ~s ... " form)
 169           (force-output))))
 170
 171 (defun cmp-print-end-message ()
 172   (when *compile-print*
 173         (format t "done~%")
 174         (force-output)))
 175
 176 (defun expand-one (e)
 177   (if (consp e)
 178       (loop
 179        (if (member (first e) '(progn macrolet eval-when)) (return e))
 180        (multiple-value-bind (ee flag) (cmp-macroexpand-1 e)
 181          (if flag
 182              (setq e ee)
 183              (return e))))))
 184
 185 ;;**** %set-cmp-macro???
 186 (defun compile-one (e compile-time-too stream)
 187   (handler-case
 188    (progn
 189      (setq e (expand-one e))
 190      (case (first e)
 191        (progn (dolist (e (rest e)) (compile-one e compile-time-too stream)))
 192        (macrolet
 193         (let ((macs (second e))
 194               (env (list nil *cmp-fenv* *cmp-macros* *cmp-global-macros*))
 195               (frame nil)
 196               (body (rest (rest e)))
 197               (*cmp-fenv* *cmp-fenv*))
 198           (dolist (m macs)
 199             (push
 200              (cons (first m)
 201                    (coerce-to-macro
 202                     (parse-macro (first m) (second m) (rest (rest m)) env)))
 203              frame))
 204           (dolist (x frame) (push x *cmp-fenv*))
 205           (compile-one `(progn ,@body) compile-time-too stream)))
 206        (eval-when
 207         (let* ((sits (second e))
 208                (body `(progn ,@(rest (rest e))))
 209                (lt (or (member 'load sits) (member :load-toplevel sits)))
 210                (ct (or (member 'compile sits) (member :compile-toplevel sits)))
 211                (ex (or (member 'eval sits) (member :execute sits))))
 212           (cond
 213            ((or (and lt ct)
 214                 (and lt (not ct) ex compile-time-too))
 215             (compile-one body t stream))
 216            ((or (and lt (not ct) (not compile-time-too))
 217                 (and lt (not ct) (not ex)))
 218             (compile-one body nil stream))
 219            ((or (and (not lt) ct)
 220                 (and (not lt) (not ct) ex compile-time-too))
 221             (eval body)))))
 222        (t (if compile-time-too (eval e))
 223           (compile-form e stream))))
 224    (error (c)
 225           (format *error-output* "~&Compiler error: ~a~%" c)
 226           ;;****(format stream "~&;;**** Error compiling exression:~%")
 227           (compile-form `(eval ',e) stream))))
 228
 229 ;;**** could ignore top level atoms, (function ...) expressions
 230 (defun compile-form (e outstuff)
 231   (labels ((cmparg (e)
 232              (cond
 233               ((and (consp e)
 234                     (eq (first e) 'function)
 235                     (consp (second e))
 236                     (eq (first (second e)) 'lambda))
 237                ;;**** should be put in quote?
 238                `(byte-code-close (quote ,(assemble (cmp (second e))))))
 239               ((consp e) (rcmp e))
 240               (t e)))
 241            (rcmp (e)
 242              (if (consp e)
 243                  (let ((f (first e)))
 244                    (if (and (symbolp f)
 245                             (not (assoc f *cmp-fenv*))
 246                             (not (assoc f *cmp-macros*))
 247                             (not (assoc f *cmp-global-macros*))
 248                             (fboundp f)
 249                             (functionp (symbol-function f)))
 250                        `(,(first e) ,@(mapcar #'cmparg (rest e)))
 251                        e))
 252                  e)))
 253     (handler-case
 254      (let ((ce (rcmp e)))
 255        ;;**** don't need the test -- top level (function ...) 's are not done
 256        (accumulate-compiled-form
 257         (if (typep ce 'byte-code) ce (assemble (cmp ce)))
 258         ;(if (typep ce 'byte-code) ce (assemble (cmp `(eval ',ce))))
 259         outstuff))
 260      (error (c)
 261             (format *error-output* "~&Compiler error: ~a~%" c)
 262             (accumulate-compiled-form (assemble (cmp `(eval ',e)))
 263                                       outstuff)))))
 264
 265
 266 #|
 267 (defun compile-form (e outstuff)
 268     (accumulate-compiled-form (assemble (cmp e)) outstuff))
 269 |#
 270
 271 (defun print-fsl-version-check (out sp)
 272   (let ((major xlisp::*fsl-major-version*)
 273         (minor xlisp::*fsl-minor-version*))
 274     (print-compiled-form `(xlisp::check-fsl-version ,major ,minor) out sp)))
 275
 276 ;;**** need to avoid creating bad .fsl file
 277 (defun compile-file (file &key
 278                           (output-file (merge-pathnames ".fsl" file))
 279                           (temporary-file (merge-pathnames "cmptmp.fsl" file))
 280                           (load nil)
 281                           ((:print *compile-print*) *compile-print*)
 282                           ((:verbose *compile-verbose*) *compile-verbose*)
 283                           ((:print-symbol-package sp) ;;**** do this cleaner
 284                            *compile-print-symbol-package*))
 285   (let* ((*package* *package*)
 286          (*readtable* *readtable*)
 287          (*cmp-specials* nil)
 288          (*cmp-macros* nil)
 289          (*cmp-setf* nil)
 290          (*cmp-structs* nil)
 291          (iname (merge-pathnames ".lsp" file)))
 292     (with-open-file (in iname)
 293       (with-open-file (out temporary-file :direction :output)
 294         (when *compile-verbose*
 295               (format t "~&; compiling file ~s~%" iname)
 296               (force-output))
 297         (print-fsl-version-check out sp)
 298         (let ((eof (list 'eof)))
 299           (do ((e (read in nil eof) (read in nil eof)))
 300               ((eq e eof))
 301               (let ((outstuff (list 'progn)))
 302                 (cmp-print-start-message e)
 303                 (let ((*cmp-fenv* nil))
 304                   (compile-one e nil outstuff))
 305                 (cmp-print-end-message)
 306                 ;; this insures that a single expression is printed for
 307                 ;; each expression read -- so common literals can be
 308                 ;; handled by circle printing/reading.
 309                 (case (length outstuff)
 310                   (1 nil)
 311                   (2 (print-compiled-form (second outstuff) out sp))
 312                   (t (print-compiled-form (assemble (cmp `(eval ',outstuff)))
 313                                           out
 314                                           sp))))))))
 315     (rename-file temporary-file output-file)
 316     (if load (load output-file))))
 317
 318 ;;**** this doesn't currently work for compiling macros
 319 (defun compile-lambda-expression (fun name env macrop)
 320   (when env (error "COMPILE can only compile top level definitions"))
 321   (let ((*cmp-specials* nil)
 322         (*cmp-macros* nil)
 323         (*cmp-fenv* nil)
 324         (*cmp-setf* nil)
 325         (*cmp-structs* nil))
 326     (let* ((fun (if macrop (cons 'lambda (rest fun)) fun))
 327            (cfun (byte-code-close (assemble (cmp fun name)))))
 328       (if macrop (coerce-to-macro cfun) cfun))))
 329
 330 (defun compile-return (f cfun)
 331   (if f
 332       (xlisp::install-function f cfun)
 333     cfun))
 334
 335 (defun compile (f &optional (fun (symbol-function f)))
 336   (cond
 337    ((or (typep fun 'subr) (typep fun 'fsubr) (compiled-function-p fun))
 338     (compile-return f fun))
 339    ((typep fun 'closure)
 340     (multiple-value-bind (flam top fname) (function-lambda-expression fun)
 341       (let ((name (if f f fname))
 342             (macrop (eq (first flam) 'macro)))
 343         (compile-return f (compile-lambda-expression flam name top macrop)))))
 344    ((and (consp fun) (eq (first fun) 'lambda))
 345     (compile-return f (compile-lambda-expression fun f nil nil)))
 346    (t (error "bad argument type -- ~s" fun))))
 347
 348 (provide "cmpload")