gistfile1.scm

(use-modules (srfi srfi-1))
(use-modules (ice-9 format))

(define val  cons)
(define stmt car)
(define expr cdr)

(define (compile x return?)
  (cond ((number? x) (val "" (fmt "~a" x)))
	((string? x) (val "" (fmt "~s" x)))
	((symbol? x) (val "" (fmt "$~a" x)))
	((if?     x) (compile-if (second x) (third x) (fourth x) return?))
	((begin?  x) (compile-begin (cdr x) return?))
	((lambda? x) (compile-lambda x return?))
	((apply?  x) (compile-apply x return?))
	(else        (error "bad form" x))))
(define (compile-if pred- then- alt- return?)
  (let ((then (compile then- return?))
	(alt  (compile alt-  return?)))
    (if (and (string-null? (stmt then)) (string-null? (stmt alt)))
	(let ((pred (compile pred- return?)))
	  (if return?
	      (val (stmt pred)
		   (fmt "~a ? ~a : ~a" (expr pred) (expr then) (expr alt)))
	      (val (stmt pred)
		   "null")))
	(let ((pred (compile-val pred-)))
	  (if return?
	      (let ((result (fmt "$~a" (gensym "if-"))))
		(val (fmt "~aif (~a) {~%~a~a = ~a;~%}~%else {~%~a~a = ~a;~%}~%"
			  (stmt pred) (expr pred)
			  (stmt then) result (expr then)
			  (stmt alt)  result (expr alt))
		     result))
	      (val (fmt "~aif (~a) {~%~a}~%else {~%~a}~%"
			(stmt pred) (expr pred) (stmt then) (stmt alt))
		   "null"))))))
(define (compile-begin forms return?)
  (let ((butlast (map compile-stmt (drop-right forms 1)))
	(last    (compile (last forms) return?)))
    (val (fmt "~{~a~}~a" (map stmt butlast) (stmt last))
	 (if return? (expr last) "null"))))
(define (compile-lambda form return?)
  (let ((bound   (second form))
	(body    (compile-val (third form)))
	(closure (free form)))
    (if return?
	(val "" (fmt "function(~{$~a~^, ~}) use(~{&$~a~^, ~}) {~%~areturn ~a;~%}"
		     bound closure (stmt body) (expr body)))
	(val "" "null"))))

(define (unique lst)
  (fold (lambda (x acc) (if (memq x acc) acc (cons x acc)))
	'() lst))
(define (free- x)
  (cond ((or (number? x) (string? x)) '())
	((symbol? x) (list x))
	((or (if? x) (begin? x)) (apply append (map free- (cdr x))))
	((lambda? x) (let ((bound (second x))
			   (body  (third  x)))
		       (remove (lambda (x) (memq x bound)) (free- body))))
	((apply?  x) (apply append (map free- x)))
	(else        (error "bad form" x))))
(define (free x)
  (unique (free- x)))

;
; FIXME: args eval order
; FIXME: call_user_func
;
(define (compile-apply proc- args- return?)
  (let ((proc (compile-val proc))
	(args (map compile-val args-)))
    (let ((call (if )))
      (if return?
	  (val (fmt "~{~a~}" (map stmt vals))
	       call)
	  (val (fmt "~{~a~}~a;~%" (map stmt vals) call)
	       "null")))))

(define (compile-val x)
  (compile x #t))
(define (compile-stmt x)
  (compile x #f))

;;;; Utils

(define (form? x name len)
  (and (list? x)
       (if (number? len) (= len (length x)) (len (length x)))
       (eq? name (car x))))
(define (if? x)
  (form? x 'if 4))
(define (begin? x)
  (form? x 'begin (lambda (len) (< 1 len))))
(define (lambda? x)
  (form? x 'lambda 3))
(define (apply? x)
  (and (list? x) (< 0 (length x))))
(define (let? x)
  (form? x 'let 3))

(define (fmt . args)
  (apply format (cons #f args)))

(define code '((lambda (make-user)
		 ((lambda (butjok)
		    (display (butjok "name")))
		  (make-user "butjok" 22)))
	       (lambda (name age)
		 (lambda (message)
		   (if (equal message "name")
		       name
		       age)))))
(display (stmt (compile-stmt code)))