From a89d6c82e981fec7d6e4c975e083d2b9e04467ad Mon Sep 17 00:00:00 2001
From: Rose Hogenson <rhogenson@posteo.net>
Date: Mon, 1 May 2023 07:56:42 -0700
Subject: Rewrite most of the compiler.

This represents a major step back in terms of functionality, and amount
of code. The latter I think constitutes a major win. Next steps are to
reimplement syntax-rules, call/cc, and call-with-values.
---
 lib/csc/compiler.scheme | 263 ++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 263 insertions(+)
 create mode 100644 lib/csc/compiler.scheme

(limited to 'lib/csc/compiler.scheme')

diff --git a/lib/csc/compiler.scheme b/lib/csc/compiler.scheme
new file mode 100644
index 0000000..b687038
--- /dev/null
+++ b/lib/csc/compiler.scheme
@@ -0,0 +1,263 @@
+(define-library (csc compiler)
+  (export compile)
+  (import (scheme base)
+          (only (scheme read) read)
+          (only (scheme write) write)
+          (prefix (csc codegen) codegen.)
+          (prefix (csc config) config.)
+          (prefix (csc cps) cps.)
+          (prefix (csc encoding) encoding.)
+          (prefix (csc ir) ir.)
+          (prefix (csc list) list.)
+          (prefix (csc macros) macros.)
+          (prefix (csc map) map.)
+          (prefix (scheme file) file.))
+  (begin
+
+
+    (define-record-type <library>
+      (make-library name exports imports body)
+      library?
+      (name library-name)
+      (exports library-exports)
+      (imports library-imports)
+      (body library-body))
+
+
+    (define (library-name? form)
+      (and (list? form)
+           (list.all
+             (lambda (x)
+               (or (symbol? x)
+                   (and (exact-integer? x)
+                        (not (negative? x)))))
+             form)))
+
+
+    (define (sprint x)
+      (define w (open-output-string))
+      (write x w)
+      (get-output-string w))
+
+
+    (define (parse-library form)
+      (unless (and (list? form)
+                   (>= (length form) 2)
+                   (symbol=? (car form) 'define-library)
+                   (library-name? (cadr form)))
+        (error "unexpected form"))
+      (let loop ((decls (cddr form))
+                 (exports '())
+                 (imports '())
+                 (body '()))
+        (if (null? decls)
+          (make-library (sprint (cadr form)) (apply append exports) (apply append imports) (apply append (reverse body)))
+          (let ((decl (car decls)))
+            (cond
+              ((null? decl)
+                (error "invalid library declaration"))
+              ((symbol=? (car decl) 'export)
+                (loop (cdr decls) (cons (cdr decl) exports) imports body))
+              ((symbol=? (car decl) 'import)
+                (loop (cdr decls) exports (cons (cdr decls) imports) body))
+              ((symbol=? (car decl) 'begin)
+                (loop (cdr decls) exports imports (cons (cdr decls) body))))))))
+
+
+    (define (import? form)
+      (and (list? form)
+           (not (null? form))
+           (symbol=? (car form) 'import)))
+
+
+    (define (split-imports-body prog)
+      (if (or (null? prog)
+              (not (import? (car prog))))
+        (values '() prog)
+        (let-values (((imports body) (split-imports-body (cdr prog))))
+          (values (append (cdar prog) imports) body))))
+
+
+    (define (import-name import-set)
+      (unless (list? import-set)
+        (error "invalid import set"))
+      (cond
+        ((and (not (null? import-set))
+              (or (symbol=? (car import-set) 'only)
+                  (symbol=? (car import-set) 'except)
+                  (symbol=? (car import-set) 'prefix)
+                  (symbol=? (car import-set) 'rename)))
+          (library-name (cadr import-set)))
+        ((library-name? import-set)
+          (sprint import-set))
+        (else (error "invalid import form" import-set))))
+
+
+    (define (open-library library-name search-dirs)
+      (define library-roots (cons config.*standard-library-dir* search-dirs))
+      (or
+        (list.any
+          (lambda (dir)
+            (define library-path
+              (string-append
+                (apply string-append dir "/" (list.intersperse "/" (map sprint library-name)))
+                ".scheme"))
+            (guard (e ((file-error? e) #f))
+              (file.call-with-input-file library-path
+                (lambda (f)
+                  (parse-library (read f))))))
+          library-roots)
+        (error "unable to find library" library-name)))
+
+
+    (define (cmp-strings x y)
+      (cond
+        ((string=? x y) 0)
+        ((string<? x y) -1)
+        (else 1)))
+
+
+    (define *empty-string-map* (map.empty cmp-strings))
+
+
+    (define (open-imports imports search-dirs)
+      (define permanent-marks (map.singleton cmp-strings "(csc builtins)" #t))
+      (define (open-import name temporary-marks)
+        (if (map.lookup permanent-marks name #f)
+          '()
+          (if (map.lookup temporary-marks name #f)
+            (error "dependency cycle detected")
+            (let ((temporary-marks* (map.insert temporary-marks name #t)))
+              (define lib (open-library name search-dirs))
+              (define dependencies
+                (map
+                  (lambda (x)
+                    (open-import (import-name x) temporary-marks*))
+                  (library-imports lib)))
+              (set! permanent-marks (map.insert permanent-marks name #t))
+              (cons (list lib) dependencies)))))
+      (apply append
+        (map
+          (lambda (x)
+            (open-import (import-name x) *empty-string-map*))
+          imports)))
+
+
+    (define (export-map libraries)
+      (list.foldl
+        (lambda (acc x)
+          (unless (list.all symbol? (library-exports x))
+            (error "invalid export form"))
+          (map.insert acc
+            (library-name x)
+            (library-exports x)))
+        (map.singleton cmp-strings "(csc builtins)" (macros.list-builtins))
+        libraries))
+
+
+    (define (tag-library-vars expr library-name)
+      (cond
+        ((symbol? expr)
+          (ir.make-libvar library-name (symbol->string expr)))
+        ((list? expr)
+          (map (lambda (x) (tag-library-vars x library-name)) expr))
+        (else expr)))
+
+
+    (define (parse-import-set import-set exports)
+      (unless (list? import-set)
+        (error "invalid import set"))
+      (cond
+        ((library-name? import-set)
+          (let* ((libname (sprint import-set))
+                 (my-exports (map.lookup exports libname)))
+            (unless (list.all symbol? my-exports)
+              (error "invalid exports" libname my-exports))
+            (list.foldl
+              (lambda (acc x)
+                (define x-str (symbol->string x))
+                (map.insert acc
+                  x-str
+                  (ir.make-libvar libname x-str)))
+              *empty-string-map*
+              my-exports)))
+        ((and (>= (length import-set) 2)
+              (symbol=? (car import-set) 'only))
+          (let ((subimports (parse-import-set (cadr import-set) exports))
+                (only-these (map.list->map cmp-strings (map (lambda (x) (cons (symbol->string x) #f)) (cddr import-set)))))
+            (map.intersect only-these subimports)))
+        ((and (>= (length import-set) 2)
+              (symbol=? (car import-set) 'except))
+          (let ((subimports (parse-import-set (cadr import-set) exports))
+                (skip-these (map.list->map cmp-strings (map (lambda (x) (cons (symbol->string x) #f)) (cddr import-set)))))
+            (map.intersect subimports skip-these)))
+        ((and (= (length import-set) 3)
+              (symbol=? (car import-set) 'prefix))
+          (let-values (((set prefix) (apply values (cdr import-set))))
+            (define subimports (parse-import-set set exports))
+            (unless (symbol? prefix)
+              (error "invalid prefix" prefix))
+            (let ((prefix-str (symbol->string prefix)))
+              (list.foldl
+                (lambda (acc x)
+                  (map.insert acc
+                    (string-append prefix-str (car x))
+                    (cdr x)))
+                *empty-string-map*
+                (map.map->list subimports)))))
+        ((and (>= (length import-set) 2)
+              (symbol=? (car import-set) 'rename))
+          (let ((subimports (parse-import-set (cadr import-set) exports)))
+            (list.foldl
+              (lambda (acc x)
+                (unless (and (list? x)
+                             (= (length x) 2)
+                             (list.all symbol? x))
+                  (error "invalid rename form"))
+                (let* ((in-str (symbol->string (car x)))
+                       (prev-binding (map.lookup acc in-str #f)))
+                  (unless prev-binding
+                    (error "cannot rename symbol" in-str))
+                  (map.insert
+                    (map.delete acc in-str)
+                    (symbol->string (cadr x))
+                    prev-binding)))
+              subimports
+              (cddr import-set))))
+        (else (error "invalid import set" import-set))))
+
+
+    (define (shuffle-imports name imports exports)
+      (define import-map
+        (apply map.union
+          *empty-string-map*
+          (map (lambda (x) (parse-import-set x exports))
+            imports)))
+      (map
+        (lambda (x)
+          (list (ir.make-libvar "(csc builtins)" "define")
+                (ir.make-libvar name (car x))
+                (cdr x)))
+        (map.map->list import-map)))
+
+
+    (define (mangle-library l exports)
+      (append
+        (shuffle-imports (library-name l) (library-imports l) exports)
+        (map
+          (lambda (x)
+            (tag-library-vars x (library-name l)))
+          (library-body l))))
+
+
+    (define (compile prog library-search-dirs)
+      (define-values (imports body) (split-imports-body prog))
+      (define libraries (open-imports imports library-search-dirs))
+      (define exports (export-map libraries))
+      (define whole-prog (append (apply append (map (lambda (x) (mangle-library x exports)) libraries))
+                                 (shuffle-imports "__main__" imports exports)
+                                 (map (lambda (x) (tag-library-vars x "__main__")) body)))
+      (define expanded (macros.expand-program whole-prog))
+      (define cps (cps.ir->cps expanded))
+      (define bytecode (codegen.cps->bytecode cps))
+      (encoding.encode bytecode))))
-- 
cgit v1.3.1