break out compilation entry points

regenerate defpackages in source
provide for comments in generated source

coalton.asd

@@ -120,6 +120,7 @@
                              (:file "package")))
                (:file "unlock-package" :if-feature :sb-package-locks)
                (:file "entry")
+               (:file "compiler")
                (:file "reader")
                (:file "main")
                (:file "debug")

emacs/coalton-mode.el

@@ -147,7 +147,7 @@
   (let ((C '(coalton-available-p)))
     `("Coalton"
       ("Debug"
-       [ "Show AST"         slime-coalton--ast ,C ])
+       [ "Show AST"         slime-coalton--ast-file ,C ])
       ("Compile"
        [ "Compile File"     slime-coalton--compile-file ,C ]))))
 

emacs/slime-coalton.el

@@ -6,8 +6,9 @@
 (require 'slime)
 
 (defun coalton-available-p ()
+  ;; todo: associate tests with specific connections
   (and (not (null slime-net-processes))
-       (fboundp 'xxx)))
+       (eql :loaded (slime-eval `(swank:swank-coalton-status)))))
 
 (cl-defmacro slime-coalton--show ((name) &body body)
   (declare (indent 1))
@@ -41,14 +42,21 @@
     ((:abort condition)
      (message "Evaluation aborted on %s." condition))))
 
-(defun slime-coalton--ast ()
-  "Display the AST of the definition at point."
+(defun slime-coalton--ast-file ()
+  "Display the AST of the current file."
   (interactive)
-  (let ((form (coalton-definition-at-point))
-        (package (coalton-package)))
-    (slime-coalton--eval `(swank:swank-coalton-ast `,form `,package)
-      (lambda (result)
-        (slime-coalton--popup 'ast result)))))
+  (slime-coalton--eval `(swank:swank-coalton--ast-file
+                         ,(buffer-substring-no-properties (point-min) (point-max)))
+    (lambda (result)
+      (slime-coalton--popup 'ast result))))
+
+(defun slime-coalton--compile-file ()
+  "Compile the current file."
+  (interactive)
+  (slime-coalton--eval `(swank:swank-coalton--compile-file
+                         ,(buffer-substring-no-properties (point-min) (point-max)))
+    (lambda (result)
+      (slime-coalton--popup 'ast result))))
 
 
 ;;; Initialization

emacs/swank-coalton.lisp

@@ -25,15 +25,10 @@
   (asdf:load-system "coalton"))
 
 
-(defslimefun swank-coalton--ast (form package)
-  :xyz)
-
-(provide :swank-coalton)
-
-
-
-(swank-coalton--ast "(define (symbol-name sym)
-  (match sym
-    ((Symbol s) s)))"
-                    "(package diff-example)")
+(defslimefun swank-coalton--ast-file (text)
+  (with-input-from-string (stream text)
+    (coalton-impl/reader::generate-ast stream))) ; todo kick out of reader
 
+(defslimefun swank-coalton--compile-file (text)
+  (with-input-from-string (stream text)
+    (coalton-impl/reader::%compile-file stream))) ; todo kick out of reader

examples/small-coalton-programs/src/diff.coalton

@@ -1,4 +1,5 @@
-(package diff-example)
+(package diff-example
+  (import coalton-prelude))
 
 ;; This program computes symbolic derivatives of simple
 ;; expressions. It uses a new Symbol data type for demonstration

src/codegen/output.lisp

@@ -4,9 +4,10 @@
   (:export
    #:emit
    #:emit-ast
+   #:emit-comment
    #:emit-env))
 
-;; Protocol for collecting compilation output
+;; Protocol for collection of compilation output
 ;;
 ;; Compiling a Coalton program produces a sequence of updates to an
 ;; initial global environment and a sequence of Lisp definitions that
@@ -32,6 +33,12 @@
   (:method (collector form)
     (declare (ignore collector form))))
 
+(defgeneric emit-comment (collector comment)
+  (:documentation
+   "Emit a comment.")
+  (:method (collector comment)
+    (declare (ignore collector comment))))
+
 (defgeneric emit-ast (collector name type value)
   (:documentation
    "Emit an AST entry.")

src/codegen/package.lisp

@@ -29,20 +29,16 @@
    #:coalton-impl/codegen/output
    #:emit
    #:emit-ast
+   #:emit-comment
    #:emit-env)
   (:export
    #:emit
    #:emit-ast
+   #:emit-comment
    #:emit-env)
 
   (:import-from
    #:coalton-impl/codegen/program
-   #:compile-translation-unit
-   #:emit
-   #:emit-ast
-   #:emit-env)
+   #:compile-translation-unit)
   (:export
-   #:compile-translation-unit
-   #:emit
-   #:emit-ast
-   #:emit-env))
+   #:compile-translation-unit))

src/compiler.lisp

@@ -0,0 +1,96 @@
+(defpackage #:coalton-impl/compiler
+  (:use
+   #:cl)
+  (:local-nicknames
+   (#:codegen #:coalton-impl/codegen)
+   (#:util #:coalton-impl/util)
+   (#:error #:coalton-impl/error)
+   (#:parser #:coalton-impl/parser)
+   (#:entry #:coalton-impl/entry))
+  (:export
+   #:collector-result
+   #:compile-toplevel
+   #:generate-ast
+   #:generate-code))
+
+(in-package #:coalton-impl/compiler)
+
+(defun process-source (source-stream source-name collector)
+  (let* ((file (error:make-coalton-file :stream source-stream
+                                        :name source-name))
+         (program (parser:read-file source-stream file)))
+    (entry:emit-prologue collector)
+    (codegen:emit collector (parser:generate-package (parser:program-package-src program)))
+    (entry:entry-point program collector)))
+
+(defgeneric collector-result (collector)
+  (:method (collector)
+    (declare (ignore collector))
+    (values)))
+
+(defclass compile-toplevel ()
+  ((forms :initform (make-array 0 :adjustable t :fill-pointer 0))))
+
+(defmethod codegen:emit ((collector compile-toplevel) form)
+  (vector-push-extend form (slot-value collector 'forms)))
+
+(defmethod codegen:emit-env ((collector compile-toplevel) name args)
+  (codegen:emit collector
+                `(setf entry:*global-environment*
+                       (,name entry:*global-environment*
+                              ,@(mapcar #'util:runtime-quote args)))))
+
+(defmethod collector-result ((collector compile-toplevel))
+  `(progn ,@(coerce (slot-value collector 'forms) 'list)))
+
+(defclass %compile-file ()
+  ((stream :initarg :stream)))
+
+(defmethod codegen:emit ((collector %compile-file) form)
+  (with-slots (stream) collector
+    (let ((*package* (find-package :cl))
+          (*print-case* :downcase)
+          (*print-circle* nil))
+      (prin1 form stream)
+      (terpri stream)
+      (terpri stream))))
+
+(defmethod codegen:emit-comment ((collector %compile-file) string)
+  (with-slots (stream) collector
+    (format stream "~%;; ~A~%~%" string)))
+
+(defmethod codegen:emit-env ((collector %compile-file) name args)
+  (codegen:emit collector
+                `(setf entry:*global-environment*
+                       (,name entry:*global-environment*
+                              ,@(mapcar #'util:runtime-quote args)))))
+
+(defclass generate-code ()
+  ((forms :initform (make-array 0 :adjustable t :fill-pointer 0))))
+
+(defmethod codegen:emit ((collector generate-code) form)
+  (vector-push-extend form (slot-value collector 'forms)))
+
+(defmethod collector-result ((collector generate-code))
+  (util:runtime-quote (coerce (slot-value collector 'forms) 'list)))
+
+(defclass generate-ast ()
+  ((stream :initarg :stream)))
+
+(defmethod codegen:emit-ast ((collector generate-ast) name type value)
+  (with-slots (stream) collector
+    (format stream "~A :: ~A~%~A~%~%~%" name type value)))
+
+(defun generate-ast (stream)
+  (parser:with-reader-context stream
+    (with-output-to-string (ast-stream)
+      (let ((collector (make-instance 'generate-ast :stream ast-stream)))
+        (process-source stream "string" collector)
+        (collector-result collector))))) ; result is stringified ast
+
+(defun %compile-file (stream lisp-stream)
+  (parser:with-reader-context stream
+    (let ((collector (make-instance '%compile-file :stream lisp-stream)))
+      (codegen:emit-comment collector "Generated from XYZ")
+      (setf entry:*global-environment* (process-source stream "string" collector))
+      t)))

src/entry.lisp

@@ -11,6 +11,7 @@
    (#:codegen #:coalton-impl/codegen))
   (:export
    #:*global-environment*
+   #:emit-prologue
    #:entry-point                        ; FUNCTION
    #:expression-entry-point             ; FUNCTION
    ))
@@ -33,6 +34,7 @@
          (file (parser:program-file program))
 
          (env *global-environment*))
+
     (tc:with-update-hook (lambda (name args)
                            (codegen:emit-env out name args))
       (multiple-value-bind (type-definitions instances env)
@@ -74,10 +76,8 @@
                                              monomorphize-table)
                                     t))
                   (analysis:analyze-translation-unit translation-unit env file)
-                  (emit-prologue out)
                   (codegen:compile-translation-unit out translation-unit monomorphize-table env))))))))))
 
-
 (defun emit-prologue (out)
   (codegen:emit out
                 `(eval-when (:load-toplevel)
@@ -89,7 +89,6 @@
                           `(error "~A was compiled in development mode but loaded in release."
                                   ,(or *compile-file-pathname* *load-truename*)))))))
 
-
 (defun expression-entry-point (node file)
   (declare (type parser:node node)
            (type error:coalton-file file))

src/parser/coalton-package.lisp

@@ -9,6 +9,8 @@
   (:local-nicknames
    (#:cst #:concrete-syntax-tree))
   (:export
+   #:ensure-package
+   #:generate-package
    #:parse-package))
 
 (in-package #:coalton-impl/parser/package)
@@ -76,7 +78,7 @@
                                :replacement #'identity
                                :message "Must be one of import or export")))))))
 
-(defun parse-package-form (form file)
+(defun parse-package (form file)
   "Parse a coalton package declaration in the form of (package {name})"
 
   ;; Package declarations must start with "PACKAGE"
@@ -141,5 +143,16 @@
            (apply #'do-export-clause package args)))))
     package))
 
-(defun parse-package (form file)
-  (ensure-package (parse-package-form form file)))
+(defun package-def-name (x)
+  (cadr (find :package x :key #'car)))
+
+(defun package-use (x)
+  (cons "COALTON"
+        (mapcar #'cadr
+                (remove-if-not (lambda (clause)
+                                 (eql (car clause) :import-all)) x))))
+
+(defun generate-package (x)
+  ;; FIXME incomplete
+  `(defpackage ,(package-def-name x)
+     (:use ,@(package-use x))))

src/parser/package.lisp

@@ -3,6 +3,7 @@
    #:coalton-impl/parser/base
    #:coalton-impl/parser/reader
    #:coalton-impl/parser/types
+   #:coalton-impl/parser/package
    #:coalton-impl/parser/pattern
    #:coalton-impl/parser/expression
    #:coalton-impl/parser/toplevel

src/parser/renamer.lisp

@@ -514,6 +514,7 @@
     (values
      (make-program
       :package (program-package program)
+      :package-src (program-package-src program)
       :file (program-file program)
       :types (rename-type-variables (program-types program))
       :structs (rename-type-variables (program-structs program))

src/parser/toplevel.lisp

@@ -123,6 +123,7 @@
    #:program                                     ; STRUCT
    #:make-program                                ; CONSTRUCTOR
    #:program-package                             ; ACCESSOR
+   #:program-package-src                         ; ACCESSOR
    #:program-file                                ; ACCESSOR
    #:program-types                               ; ACCESSOR
    #:program-structs                             ; ACCESSOR
@@ -416,6 +417,7 @@
 
 (defstruct (program (:copier nil))
   (package         (util:required 'package) :type package                       :read-only t)
+  (package-src     nil                      :type (or cons null)                :read-only t)
   (file            (util:required 'file)    :type coalton-file                  :read-only t)
   (types           nil                      :type toplevel-define-type-list     :read-only nil)
   (structs         nil                      :type toplevel-define-struct-list   :read-only nil)
@@ -463,19 +465,21 @@
 (defun read-file (stream file)
   "Read a Coalton program for STREAM corresponding to coalton-file FILE. A package form is required."
   (with-eclector-readtable
-    (read-body stream (read-package stream file) file)))
+    (let ((package-src (read-package stream file)))
+      (read-body stream (ensure-package package-src) package-src file))))
 
 (defun read-program (stream file)
   "Read a PROGRAM from the COALTON-FILE."
   (declare (type coalton-file file)
            (values program &optional))
   (with-eclector-readtable
-    (read-body stream *package* file)))
+    (read-body stream *package* nil file)))
 
-(defun read-body (stream package file)
+(defun read-body (stream package package-src file)
   (declare (type coalton-file file)
            (values program))
   (let ((program (make-program :package package
+                               :package-src package-src
                                :file file))
         (*package* package)
         (attributes (make-array 0 :adjustable t :fill-pointer t)))