unscheme-impl.scm

(define (unscheme expr load-expr)
  (let loop ((expr expr))
    (define (unscheme-constructor x)
      (string->symbol (string-append ":" (symbol->string x))))
    (define (ununquote x)
      (if (and (pair? x) (eq? (car x) 'unquote))
          (loop (cadr x))
          `',x))
    (define (unscheme-case c)
      `((,(unscheme-constructor (car (car c)))
         ,@(cdr (car c)))
        ,@(map loop (cdr c))))
    (if (not (pair? expr))
        expr
        (case (car expr)
          ((load)
           load-expr)
          ((define)
           `(define ,(cadr expr) ,(loop (caddr expr))))
          ((let letrec)
           `((car expr) ,(map (lambda (bind)
                                `(,(car bind) ,(loop (cadr bind))))
                              (cadr expr))
             ,@(map loop (cddr expr))))
          ((quasiquote)
           ;; `(C ,x ,y) -> (list :C x y)
           (let ((e (cadr expr)))
             `(list ',(unscheme-constructor (car e))
                    ,@(map ununquote (cdr e)))))
          ((lambda lambdas)
           ;; (lambda (x) expr) -> (lambdas (x) expr)
           ;; (lambdas (x y ...) expr) -> (lambdas (x y ...) expr)
           `(lambdas ,(cadr expr) ,@(map loop (cddr expr))))
          ((match)
           ;; (match e ((C x y) expr) ...) -> (match e ((:C x y) expr) ...)
           `(match ,(loop (cadr expr)) ,@(map unscheme-case (cddr expr))))
          ((@ delay force error)
           ;; as-is
           (map loop expr))
          (else
           ;; unary procedure application
           `(@ ,@(map loop expr)))))))

(define (writeln x port)
  (write x port)
  (newline port))

(define (errln . msgs)
  (for-each (lambda (msg) (display msg (current-error-port))) msgs)
  (newline (current-error-port)))

(define (string-suffix? suf str)
  (let ((l1 (string-length suf))
        (l2 (string-length str)))
    (and (>= l2 l1)
         (string=? suf (substring str (- l2 l1) l2)))))

(when (not (= 3 (length (command-line))))
  (errln "usage: " (car (command-line)) " input-file output-file")
  (exit 1))

(let* ((scm (cadr (command-line)))
       (output (caddr (command-line)))
       (output-type (cond ((string-suffix? ".lisp" output) 'cl)
                          ((string-suffix? ".el" output) 'el)
                          (else
                           (errln "unknown output type: " output)
                           (exit 1))))
       (load-expr (case output-type
                    ((cl) #f)
                    ((el) '(require 'macros_extr)))))
  (call-with-output-file output
    (lambda (out)
      (when (eq? output-type 'el)
        (display ";; -*- lexical-binding: t -*-\n" out))
      (call-with-input-file scm
        (lambda (in)
          (let loop ((expr (read in)))
            (cond ((eof-object? expr)
                   (exit 0))
                  (else
                   (cond ((unscheme expr load-expr)
                          => (lambda (e) (writeln e out))))
                   (loop (read in))))))))))