path: root/lib/csc/compiler.scheme

(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))))