upscheme/system.lsp

; -*- scheme -*-
; femtoLisp standard library
; by Jeff Bezanson (C) 2009
; Distributed under the BSD License

(define (void) #t)  ; the unspecified value

(define *builtins*
  (vector
   0 0 0 0 0 0 0 0 0 0 0 0
   (lambda (x y) (eq? x y))          (lambda (x y) (eqv? x y))
   (lambda (x y) (equal? x y))       (lambda (x) (atom? x))
   (lambda (x) (not x))              (lambda (x) (null? x))
   (lambda (x) (boolean? x))         (lambda (x) (symbol? x))
   (lambda (x) (number? x))          (lambda (x) (bound? x))
   (lambda (x) (pair? x))            (lambda (x) (builtin? x))
   (lambda (x) (vector? x))          (lambda (x) (fixnum? x))
   (lambda (x) (function? x))        (lambda (x y) (cons x y))
   (lambda rest (apply list rest))   (lambda (x) (car x))
   (lambda (x) (cdr x))              (lambda (x y) (set-car! x y))
   (lambda (x y) (set-cdr! x y))     (lambda rest (apply apply rest))
   (lambda rest (apply + rest))      (lambda rest (apply - rest))
   (lambda rest (apply * rest))      (lambda rest (apply / rest))
   (lambda rest (apply div0 rest))   (lambda (x y) (= x y))
   (lambda (x y) (< x y))            (lambda (x y) (compare x y))
   (lambda rest (apply vector rest)) (lambda (x y) (aref x y))
   (lambda (x y z) (aset! x y z))))

(if (not (bound? '*syntax-environment*))
    (define *syntax-environment* (table)))

(define (set-syntax! s v) (put! *syntax-environment* s v))
(define (symbol-syntax s) (get *syntax-environment* s #f))

(define-macro (define-macro form . body)
  `(set-syntax! ',(car form)
		(lambda ,(cdr form) ,@body)))

#;(define (map1 f lst acc)
  (cdr
   (prog1 acc
	  (while (pair? lst)
		 (begin (set! acc
			      (cdr (set-cdr! acc (cons (f (car lst)) ()))))
			(set! lst (cdr lst)))))))

#;(define (mapn f lsts)
  (if (null? (car lsts))
      ()
      (cons (apply f (map1 car lsts (list ())))
	    (mapn  f (map1 cdr lsts (list ()))))))

#;(define (map f lst . lsts)
  (if (null? lsts)
      (map1 f lst (list ()))
      (mapn f (cons lst lsts))))

(define-macro (letrec binds . body)
  `((lambda ,(map car binds)
      ,.(map (lambda (b) `(set! ,@b)) binds)
      ,@body)
    ,.(map (lambda (x) (void)) binds)))

(define-macro (let binds . body)
  (let ((lname #f))
    (if (symbol? binds)
	(begin (set! lname binds)
	       (set! binds (car body))
	       (set! body (cdr body))))
    (let ((thelambda
	   `(lambda ,(map (lambda (c) (if (pair? c) (car c) c))
			  binds)
	      ,@body))
	  (theargs
	   (map (lambda (c) (if (pair? c) (cadr c) (void))) binds)))
      (cons (if lname
		`(letrec ((,lname ,thelambda)) ,lname)
		thelambda)
	    theargs))))

(define-macro (cond . clauses)
  (define (cond-clauses->if lst)
    (if (atom? lst)
	#f
	(let ((clause (car lst)))
	  (if (or (eq? (car clause) 'else)
		  (eq? (car clause) #t))
	      (if (null? (cdr clause))
		  (car clause)
		  (cons 'begin (cdr clause)))
	      (if (null? (cdr clause))
		  ; test by itself
		  (list 'or
			(car clause)
			(cond-clauses->if (cdr lst)))
		  ; test => expression
		  (if (eq? (cadr clause) '=>)
		      (if (1arg-lambda? (caddr clause))
			  ; test => (lambda (x) ...)
			  (let ((var (caadr (caddr clause))))
			    `(let ((,var ,(car clause)))
			       (if ,var ,(cons 'begin (cddr (caddr clause)))
				   ,(cond-clauses->if (cdr lst)))))
			  ; test => proc
			  (let ((b (gensym)))
			    `(let ((,b ,(car clause)))
			       (if ,b
				   (,(caddr clause) ,b)
				   ,(cond-clauses->if (cdr lst))))))
		      (list 'if
			    (car clause)
			    (cons 'begin (cdr clause))
			    (cond-clauses->if (cdr lst)))))))))
  (cond-clauses->if clauses))

; standard procedures ---------------------------------------------------------

(define (member item lst)
  (cond ((atom? lst) #f)
        ((equal?     (car lst) item) lst)
        (#t          (member item (cdr lst)))))
(define (memv item lst)
  (cond ((atom? lst) #f)
        ((eqv?       (car lst) item) lst)
        (#t          (memv item (cdr lst)))))

(define (assoc item lst)
  (cond ((atom? lst) #f)
	((equal?     (caar lst) item) (car lst))
	(#t          (assoc item (cdr lst)))))
(define (assv item lst)
  (cond ((atom? lst) #f)
	((eqv?       (caar lst) item) (car lst))
	(#t          (assv item (cdr lst)))))

(define (>  a b) (< b a))
(define (<= a b) (or (< a b) (= a b)))
(define (>= a b) (or (< b a) (= a b)))
(define (negative? x) (< x 0))
(define (zero? x)     (= x 0))
(define (positive? x) (> x 0))
(define (even? x) (= (logand x 1) 0))
(define (odd? x) (not (even? x)))
(define (identity x) x)
(define (1+ n) (+ n 1))
(define (1- n) (- n 1))
(define (mod0 x y) (- x (* (div0 x y) y)))
(define (div x y) (+ (div0 x y)
		     (or (and (< x 0)
			      (or (and (< y 0) 1)
				  -1))
			 0)))
(define (mod x y) (- x (* (div x y) y)))
(define (random n)
  (if (integer? n)
      (mod (rand) n)
      (* (rand.double) n)))
(define (abs x)   (if (< x 0) (- x) x))
(define (max x0 . xs)
  (if (null? xs) x0
      (foldl (lambda (a b) (if (< a b) b a)) x0 xs)))
(define (min x0 . xs)
  (if (null? xs) x0
      (foldl (lambda (a b) (if (< a b) a b)) x0 xs)))
(define (char? x) (eq? (typeof x) 'wchar))
(define (array? x) (or (vector? x)
		       (let ((t (typeof x)))
			 (and (pair? t) (eq? (car t) 'array)))))
(define (closure? x) (and (function? x) (not (builtin? x))))

(define (caar x) (car (car x)))
(define (cadr x) (car (cdr x)))
(define (cdar x) (cdr (car x)))
(define (cddr x) (cdr (cdr x)))
(define (caaar x) (car (car (car x))))
(define (caadr x) (car (car (cdr x))))
(define (cadar x) (car (cdr (car x))))
(define (caddr x) (car (cdr (cdr x))))
(define (cdaar x) (cdr (car (car x))))
(define (cdadr x) (cdr (car (cdr x))))
(define (cddar x) (cdr (cdr (car x))))
(define (cdddr x) (cdr (cdr (cdr x))))
(define (caaaar x) (car (car (car (car x)))))
(define (caaadr x) (car (car (car (cdr x)))))
(define (caadar x) (car (car (cdr (car x)))))
(define (caaddr x) (car (car (cdr (cdr x)))))
(define (cadaar x) (car (cdr (car (car x)))))
(define (cadadr x) (car (cdr (car (cdr x)))))
(define (caddar x) (car (cdr (cdr (car x)))))
(define (cadddr x) (car (cdr (cdr (cdr x)))))
(define (cdaaar x) (cdr (car (car (car x)))))
(define (cdaadr x) (cdr (car (car (cdr x)))))
(define (cdadar x) (cdr (car (cdr (car x)))))
(define (cdaddr x) (cdr (car (cdr (cdr x)))))
(define (cddaar x) (cdr (cdr (car (car x)))))
(define (cddadr x) (cdr (cdr (car (cdr x)))))
(define (cdddar x) (cdr (cdr (cdr (car x)))))
(define (cddddr x) (cdr (cdr (cdr (cdr x)))))

(let ((*values* (list '*values*)))
  (set! values
	(lambda vs
	  (if (and (pair? vs) (null? (cdr vs)))
	      (car vs)
	      (cons *values* vs))))
  (set! call-with-values
	(lambda (producer consumer)
	  (let ((res (producer)))
	    (if (and (pair? res) (eq? *values* (car res)))
		(apply consumer (cdr res))
		(consumer res))))))

; list utilities --------------------------------------------------------------

(define (every pred lst)
  (or (atom? lst)
      (and (pred (car lst))
           (every pred (cdr lst)))))

(define (any pred lst)
  (and (pair? lst)
       (or (pred (car lst))
           (any pred (cdr lst)))))

(define (list? a) (or (null? a) (and (pair? a) (list? (cdr a)))))

(define (list-tail lst n)
  (if (<= n 0) lst
      (list-tail (cdr lst) (- n 1))))

(define (list-head lst n)
  (if (<= n 0) ()
      (cons (car lst)
	    (list-head (cdr lst) (- n 1)))))

(define (list-ref lst n)
  (car (list-tail lst n)))

; bounded length test
; use this instead of (= (length lst) n), since it avoids unnecessary
; work and always terminates.
(define (length= lst n)
  (cond ((< n 0)     #f)
	((= n 0)     (atom? lst))
	((atom? lst) (= n 0))
	(else        (length= (cdr lst) (- n 1)))))

(define (length> lst n)
  (cond ((< n 0)     lst)
	((= n 0)     (and (pair? lst) lst))
	((atom? lst) (< n 0))
	(else        (length> (cdr lst) (- n 1)))))

(define (last-pair l)
  (if (atom? (cdr l))
      l
      (last-pair (cdr l))))

(define (lastcdr l)
  (if (atom? l)
      l
      (cdr (last-pair l))))

(define (to-proper l)
  (cond ((null? l) l)
	((atom? l) (list l))
	(else (cons (car l) (to-proper (cdr l))))))

(define (map! f lst)
  (prog1 lst
	 (while (pair? lst)
		(set-car! lst (f (car lst)))
		(set! lst (cdr lst)))))

(define (filter pred lst)
  (define (filter- f lst acc)
    (cdr
     (prog1 acc
      (while (pair? lst)
	     (begin (if (pred (car lst))
			(set! acc
			      (cdr (set-cdr! acc (cons (car lst) ())))))
		    (set! lst (cdr lst)))))))
  (filter- pred lst (list ())))

(define (separate pred lst)
  (define (separate- pred lst yes no)
    (let ((vals
	   (prog1
	    (cons yes no)
	    (while (pair? lst)
		   (begin (if (pred (car lst))
			      (set! yes
				    (cdr (set-cdr! yes (cons (car lst) ()))))
			      (set! no
				    (cdr (set-cdr! no  (cons (car lst) ())))))
			  (set! lst (cdr lst)))))))
      (values (cdr (car vals)) (cdr (cdr vals)))))
  (separate- pred lst (list ()) (list ())))

(define (count f l)
  (define (count- f l n)
    (if (null? l)
	n
	(count- f (cdr l) (if (f (car l))
			      (+ n 1)
			      n))))
  (count- f l 0))

(define (nestlist f zero n)
  (if (<= n 0) ()
      (cons zero (nestlist f (f zero) (- n 1)))))

(define (foldr f zero lst)
  (if (null? lst) zero
      (f (car lst) (foldr f zero (cdr lst)))))

(define (foldl f zero lst)
  (if (null? lst) zero
      (foldl f (f (car lst) zero) (cdr lst))))

(define (reverse- zero lst)
  (if (null? lst) zero
      (reverse- (cons (car lst) zero) (cdr lst))))

(define (reverse lst) (reverse- () lst))

(define (reverse!- prev l)
  (while (pair? l)
	 (set! l (prog1 (cdr l)
			(set-cdr! l (prog1 prev
					   (set! prev l))))))
  prev)

(define (reverse! l) (reverse!- () l))

(define (copy-tree l)
  (if (atom? l) l
    (cons (copy-tree (car l))
          (copy-tree (cdr l)))))

(define (delete-duplicates lst)
  (if (atom? lst)
      lst
      (let ((elt  (car lst))
	    (tail (cdr lst)))
	(if (member elt tail)
	    (delete-duplicates tail)
	    (cons elt
		  (delete-duplicates tail))))))

; backquote -------------------------------------------------------------------

(define (revappend l1 l2) (reverse-  l2 l1))
(define (nreconc   l1 l2) (reverse!- l2 l1))

(define (self-evaluating? x)
  (or (and (atom? x)
           (not (symbol? x)))
      (and (constant? x)
	   (symbol? x)
           (eq x (top-level-value x)))))

(define-macro (quasiquote x) (bq-process x 0))

(define (splice-form? x)
  (or (and (pair? x) (or (eq? (car x) 'unquote-splicing)
			 (eq? (car x) 'unquote-nsplicing)
			 (and (eq? (car x) 'unquote)
			      (length> x 2))))
      (eq? x 'unquote)))

;; bracket without splicing
(define (bq-bracket1 x d)
  (if (and (pair? x) (eq? (car x) 'unquote))
      (if (= d 0)
	  (cadr x)
	  (list cons ''unquote
		(bq-process (cdr x) (- d 1))))
      (bq-process x d)))

(define (bq-bracket x d)
  (cond ((atom? x)  (list list (bq-process x d)))
	((eq? (car x) 'unquote)
	 (if (= d 0)
	     (cons list (cdr x))
	     (list list (list cons ''unquote
			      (bq-process (cdr x) (- d 1))))))
	((eq? (car x) 'unquote-splicing)
	 (if (= d 0)
	     (list 'copy-list (cadr x))
	     (list list (list list ''unquote-splicing
			      (bq-process (cadr x) (- d 1))))))
	((eq? (car x) 'unquote-nsplicing)
	 (if (= d 0)
	     (cadr x)
	     (list list (list list ''unquote-nsplicing
			      (bq-process (cadr x) (- d 1))))))
	(else  (list list (bq-process x d)))))

(define (bq-process x d)
  (cond ((symbol? x)  (list 'quote x))
	((vector? x)
	 (let ((body (bq-process (vector->list x) d)))
	   (if (eq? (car body) list)
	       (cons vector (cdr body))
	       (list apply vector body))))
        ((atom? x)  x)
        ((eq? (car x) 'quasiquote)
	 (list list ''quasiquote (bq-process (cadr x) (+ d 1))))
        ((eq? (car x) 'unquote)
	 (if (and (= d 0) (length= x 2))
	     (cadr x)
	     (list cons ''unquote (bq-process (cdr x) (- d 1)))))
	((or (> d 0) (not (any splice-form? x)))
         (let ((lc    (lastcdr x))
               (forms (map (lambda (x) (bq-bracket1 x d)) x)))
           (if (null? lc)
               (cons list forms)
	       (if (null? (cdr forms))
		   (list cons (car forms) (bq-process lc d))
		   (nconc (cons list* forms) (list (bq-process lc d)))))))
	(else
	 (let loop ((p x) (q ()))
	   (cond ((null? p) ;; proper list
		  (cons 'nconc (reverse! q)))
		 ((pair? p)
		  (cond ((eq? (car p) 'unquote)
			 ;; (... . ,x)
			 (cons 'nconc
			       (nreconc q
					(if (= d 0)
					    (cdr p)
					    (list (list list ''unquote)
						  (bq-process (cdr p)
							       (- d 1)))))))
			(else
			 (loop (cdr p) (cons (bq-bracket (car p) d) q)))))
		 (else
		  ;; (... . x)
		  (cons 'nconc (reverse! (cons (bq-process p d) q)))))))))

; standard macros -------------------------------------------------------------

(define (quote-value v)
  (if (self-evaluating? v)
      v
      (list 'quote v)))

(define-macro (let* binds . body)
  (if (atom? binds) `((lambda () ,@body))
      `((lambda (,(caar binds))
	  ,@(if (pair? (cdr binds))
		`((let* ,(cdr binds) ,@body))
		body))
	,(cadar binds))))

(define-macro (when   c . body) (list 'if c (cons 'begin body) #f))
(define-macro (unless c . body) (list 'if c #f (cons 'begin body)))

(define-macro (case key . clauses)
  (define (vals->cond key v)
    (cond ((eq? v 'else)   'else)
	  ((null? v)       #f)
	  ((symbol? v)     `(eq?  ,key ,(quote-value v)))
          ((atom? v)       `(eqv? ,key ,(quote-value v)))
	  ((null? (cdr v)) `(eqv? ,key ,(quote-value (car v))))
	  ((every symbol? v)
	                   `(memq ,key ',v))
	  (else            `(memv ,key ',v))))
  (let ((g (gensym)))
    `(let ((,g ,key))
       (cond ,.(map (lambda (clause)
		      (cons (vals->cond g (car clause))
			    (cdr clause)))
		    clauses)))))

(define-macro (do vars test-spec . commands)
  (let ((loop (gensym))
	(test-expr (car test-spec))
	(vars  (map car  vars))
	(inits (map cadr vars))
	(steps (map (lambda (x)
		      (if (pair? (cddr x))
			  (caddr x)
			  (car x)))
		    vars)))
    `(letrec ((,loop (lambda ,vars
		       (if ,test-expr
			   (begin
			     ,@(cdr test-spec))
			   (begin
			     ,@commands
			     (,loop ,.steps))))))
       (,loop ,.inits))))

; SRFI 8
(define-macro (receive formals expr . body)
  `(call-with-values (lambda () ,expr)
     (lambda ,formals ,@body)))

(define-macro (dotimes var . body)
  (let ((v (car var))
        (cnt (cadr var)))
    `(for 0 (- ,cnt 1)
          (lambda (,v) ,@body))))

(define (map-int f n)
  (if (<= n 0)
      ()
    (let ((first (cons (f 0) ()))
          (acc ()))
      (set! acc first)
      (for 1 (- n 1)
           (lambda (i)
             (begin (set-cdr! acc (cons (f i) ()))
                    (set! acc (cdr acc)))))
      first)))

(define (iota n) (map-int identity n))

(define (for-each f l . lsts)
  (define (for-each-n f lsts)
    (if (pair? (car lsts))
	(begin (apply f (map car lsts))
	       (for-each-n f (map cdr lsts)))))
  (if (null? lsts)
      (while (pair? l)
	     (begin (f (car l))
		    (set! l (cdr l))))
      (for-each-n f (cons l lsts)))
  #t)

(define-macro (with-bindings binds . body)
  (let ((vars (map car binds))
	(vals (map cadr binds))
	(olds (map (lambda (x) (gensym)) binds)))
    `(let ,(map list olds vars)
       ,@(map (lambda (v val) `(set! ,v ,val)) vars vals)
       (unwind-protect
	(begin ,@body)
	(begin ,@(map (lambda (v old) `(set! ,v ,old)) vars olds))))))

; exceptions ------------------------------------------------------------------

(define (error . args) (raise (cons 'error args)))

(define-macro (throw tag value) `(raise (list 'thrown-value ,tag ,value)))
(define-macro (catch tag expr)
  (let ((e (gensym)))
    `(trycatch ,expr
               (lambda (,e) (if (and (pair? ,e)
                                     (eq (car  ,e) 'thrown-value)
                                     (eq (cadr ,e) ,tag))
                                (caddr ,e)
				(raise ,e))))))

(define-macro (unwind-protect expr finally)
  (let ((e   (gensym))
	(thk (gensym)))
    `(let ((,thk (lambda () ,finally)))
       (prog1 (trycatch ,expr
			(lambda (,e) (begin (,thk) (raise ,e))))
	      (,thk)))))

; debugging utilities ---------------------------------------------------------

(define-macro (assert expr) `(if ,expr #t (raise '(assert-failed ,expr))))

(define traced?
  (letrec ((sample-traced-lambda (lambda args (begin (write (cons 'x args))
						     (newline)
						     (apply #.apply args)))))
    (lambda (f)
      (and (closure? f)
	   (equal? (function:code f)
		   (function:code sample-traced-lambda))))))

(define (trace sym)
  (let* ((func (top-level-value sym))
	 (args (gensym)))
    (if (not (traced? func))
	(set-top-level-value! sym
			      (eval
			       `(lambda ,args
				  (begin (write (cons ',sym ,args))
					 (newline)
					 (apply ',func ,args)))))))
  'ok)

(define (untrace sym)
  (let ((func (top-level-value sym)))
    (if (traced? func)
	(set-top-level-value! sym
			      (aref (function:vals func) 2)))))

(define-macro (time expr)
  (let ((t0 (gensym)))
    `(let ((,t0 (time.now)))
       (prog1
	,expr
	(princ "Elapsed time: " (- (time.now) ,t0) " seconds\n")))))

; text I/O --------------------------------------------------------------------

(define (print . args) (for-each write args))
(define (princ . args)
  (with-bindings ((*print-readably* #f))
		 (for-each write args)))

(define (newline (port *output-stream*))
  (io.write port *linefeed*)
  #t)

(define (io.readline s) (io.readuntil s #\linefeed))

; call f on a stream until the stream runs out of data
(define (read-all-of f s)
  (let loop ((lines ())
	     (curr  (f s)))
    (if (io.eof? s)
	(reverse! lines)
	(loop (cons curr lines) (f s)))))

(define (io.readlines s) (read-all-of io.readline s))
(define (read-all s) (read-all-of read s))

(define (io.readall s)
  (let ((b (buffer)))
    (io.copy b s)
    (let ((str (io.tostring! b)))
      (if (and (equal? str "") (io.eof? s))
	  (eof-object)
	  str))))

(define-macro (with-output-to stream . body)
  `(with-bindings ((*output-stream* ,stream))
		  ,@body))
(define-macro (with-input-from stream . body)
  `(with-bindings ((*input-stream* ,stream))
		  ,@body))

; vector functions ------------------------------------------------------------

(define (list->vector l) (apply vector l))
(define (vector->list v)
  (let ((n (length v))
        (l ()))
    (for 1 n
         (lambda (i)
           (set! l (cons (aref v (- n i)) l))))
    l))

(define (vector.map f v)
  (let* ((n (length v))
         (nv (vector.alloc n)))
    (for 0 (- n 1)
         (lambda (i)
           (aset! nv i (f (aref v i)))))
    nv))

; table functions -------------------------------------------------------------

(define (table.pairs t)
  (table.foldl (lambda (k v z) (cons (cons k v) z))
               () t))
(define (table.keys t)
  (table.foldl (lambda (k v z) (cons k z))
               () t))
(define (table.values t)
  (table.foldl (lambda (k v z) (cons v z))
               () t))
(define (table.clone t)
  (let ((nt (table)))
    (table.foldl (lambda (k v z) (put! nt k v))
                 () t)
    nt))
(define (table.invert t)
  (let ((nt (table)))
    (table.foldl (lambda (k v z) (put! nt v k))
		 () t)
    nt))
(define (table.foreach f t)
  (table.foldl (lambda (k v z) (begin (f k v) #t)) () t))

; string functions ------------------------------------------------------------

(define (string.tail s n) (string.sub s (string.inc s 0 n)))

(define *whitespace*
  (string.encode #array(wchar 9 10 11 12 13 32 133 160 5760 6158 8192
			      8193 8194 8195 8196 8197 8198 8199 8200
			      8201 8202 8232 8233 8239 8287 12288)))

(define (string.trim s at-start at-end)
  (define (trim-start s chars i L)
    (if (and (< i L)
	     (string.find chars (string.char s i)))
	(trim-start s chars (string.inc s i) L)
	i))
  (define (trim-end s chars i)
    (if (and (> i 0)
	     (string.find chars (string.char s (string.dec s i))))
	(trim-end s chars (string.dec s i))
	i))
  (let ((L (length s)))
    (string.sub s
		(trim-start s at-start 0 L)
		(trim-end   s at-end   L))))

(define (string.map f s)
  (let ((b (buffer))
	(n (length s)))
    (let ((i 0))
      (while (< i n)
	     (begin (io.putc b (f (string.char s i)))
		    (set! i (string.inc s i)))))
    (io.tostring! b)))

(define (string.rep s k)
  (cond ((< k 4)
	 (cond ((<= k 0) "")
	       ((=  k 1) (string s))
	       ((=  k 2) (string s s))
	       (else     (string s s s))))
	((odd? k) (string s (string.rep s (- k 1))))
	(else     (string.rep (string s s) (/ k 2)))))

(define (string.lpad s n c) (string (string.rep c (- n (string.count s))) s))
(define (string.rpad s n c) (string s (string.rep c (- n (string.count s)))))

(define (print-to-string v)
  (let ((b (buffer)))
    (write v b)
    (io.tostring! b)))

(define (string.join strlist sep)
  (if (null? strlist) ""
      (let ((b (buffer)))
	(io.write b (car strlist))
	(for-each (lambda (s) (begin (io.write b sep)
				     (io.write b s)))
		  (cdr strlist))
	(io.tostring! b))))

; toplevel --------------------------------------------------------------------

(define (macrocall? e) (and (symbol? (car e))
			    (symbol-syntax (car e))))

(define (macroexpand-1 e)
  (if (atom? e) e
      (let ((f (macrocall? e)))
	(if f (apply f (cdr e))
	    e))))

(define (expand e)
  ; symbol resolves to toplevel; i.e. has no shadowing definition
  (define (top? s env) (not (or (bound? s) (assq s env))))
  
  (define (splice-begin body)
    (cond ((atom? body) body)
	  ((equal? body '((begin)))
	   body)
	  ((and (pair? (car body))
		(eq? (caar body) 'begin))
	   (append (splice-begin (cdar body)) (splice-begin (cdr body))))
	  (else
	   (cons (car body) (splice-begin (cdr body))))))
  
  (define *expanded* (list '*expanded*))
  
  (define (expand-body body env)
    (if (atom? body) body
	(let* ((body  (if (top? 'begin env)
			  (splice-begin body)
			  body))
	       (def?  (top? 'define env))
	       (dvars (if def? (get-defined-vars body) ()))
	       (env   (nconc (map list dvars) env)))
	  (if (not def?)
	      (map (lambda (x) (expand-in x env)) body)
	      (let* ((ex-nondefs    ; expand non-definitions
		      (let loop ((body body))
			(cond ((atom? body) body)
			      ((and (pair? (car body))
				    (eq? 'define (caar body)))
			       (cons (car body) (loop (cdr body))))
			      (else
			       (let ((form (expand-in (car body) env)))
				 (set! env (nconc
					    (map list (get-defined-vars form))
					    env))
				 (cons
				  (cons *expanded* form)
				  (loop (cdr body))))))))
		     (body ex-nondefs))
		(while (pair? body) ; now expand deferred definitions
		       (if (not (eq? *expanded* (caar body)))
			   (set-car! body (expand-in (car body) env))
			   (set-car! body (cdar body)))
		       (set! body (cdr body)))
		ex-nondefs)))))
  
  (define (expand-lambda-list l env)
    (if (atom? l) l
	(cons (if (and (pair? (car l)) (pair? (cdr (car l))))
		  (list (caar l) (expand-in (cadar l) env))
		  (car l))
	      (expand-lambda-list (cdr l) env))))
  
  (define (l-vars l)
    (cond ((atom? l)       (list l))
	  ((pair? (car l)) (cons (caar l) (l-vars (cdr l))))
	  (else            (cons (car l)  (l-vars (cdr l))))))
  
  (define (expand-lambda e env)
    (let ((formals (cadr e))
	  (name    (lastcdr e))
	  (body    (cddr e))
	  (vars    (l-vars (cadr e))))
      (let ((env   (nconc (map list vars) env)))
	`(lambda ,(expand-lambda-list formals env)
	   ,.(expand-body body env)
	   . ,name))))
  
  (define (expand-define e env)
    (if (or (null? (cdr e)) (atom? (cadr e)))
	(if (null? (cddr e))
	    e
	    `(define ,(cadr e) ,(expand-in (caddr e) env)))
	(let ((formals (cdadr e))
	      (name    (caadr e))
	      (body    (cddr e))
	      (vars    (l-vars (cdadr e))))
	  (let ((env   (nconc (map list vars) env)))
	    `(define ,(cons name (expand-lambda-list formals env))
	       ,.(expand-body body env))))))
  
  (define (expand-let-syntax e env)
    (let ((binds (cadr e)))
      (cons 'begin
	    (expand-body (cddr e)
			 (nconc
			  (map (lambda (bind)
				 (list (car bind)
				       ((compile-thunk
					 (expand-in (cadr bind) env)))
				       env))
			       binds)
			  env)))))
  
  ; given let-syntax definition environment (menv) and environment
  ; at the point of the macro use (lenv), return the environment to
  ; expand the macro use in. TODO
  (define (local-expansion-env menv lenv) menv)
  
  (define (expand-in e env)
    (if (atom? e) e
	(let* ((head (car e))
	       (bnd  (assq head env))
	       (default (lambda ()
			  (let loop ((e e))
			    (if (atom? e) e
				(cons (if (atom? (car e))
					  (car e)
					  (expand-in (car e) env))
				      (loop (cdr e))))))))
	  (cond ((and bnd (pair? (cdr bnd)))  ; local macro
		 (expand-in (apply (cadr bnd) (cdr e))
			    (local-expansion-env (caddr bnd) env)))
		((or bnd                      ; bound lexical or toplevel var
		     (not (symbol? head))
		     (bound? head))
		 (default))
		((macrocall? e) =>      (lambda (f)
				          (expand-in (apply f (cdr e)) env)))
		((eq? head 'quote)      e)
		((eq? head 'lambda)     (expand-lambda e env))
		((eq? head 'define)     (expand-define e env))
		((eq? head 'let-syntax) (expand-let-syntax e env))
		(else                   (default))))))
  (expand-in e ()))

(define (eval x) ((compile-thunk (expand x))))

(define (load-process x) (eval x))

(define (load filename)
  (let ((F (file filename :read)))
    (trycatch
     (let next (prev E v)
       (if (not (io.eof? F))
	   (next (read F)
                 prev
		 (load-process E))
	   (begin (io.close F)
		  ; evaluate last form in almost-tail position
		  (load-process E))))
     (lambda (e)
       (begin
	 (io.close F)
	 (raise `(load-error ,filename ,e)))))))

(define *banner* (string.tail "
;  _
; |_ _ _ |_ _ |  . _ _
; | (-||||_(_)|__|_)|_)
;-------------------|----------------------------------------------------------

" 1))

(define (repl)
  (define (prompt)
    (princ "> ") (io.flush *output-stream*)
    (let ((v (trycatch (read)
		       (lambda (e) (begin (io.discardbuffer *input-stream*)
					  (raise e))))))
      (and (not (io.eof? *input-stream*))
	   (let ((V (load-process v)))
	     (print V)
	     (set! that V)
	     #t))))
  (define (reploop)
    (when (trycatch (and (prompt) (newline))
		    (lambda (e)
		      (top-level-exception-handler e)
		      #t))
	  (begin (newline)
		 (reploop))))
  (reploop)
  (newline))

(define (top-level-exception-handler e)
  (with-output-to *stderr*
		  (print-exception e)
		  (print-stack-trace (stacktrace))))

(define (print-stack-trace st)
  (define (find-in-f f tgt path)
    (let ((path (cons (function:name f) path)))
      (if (eq? (function:code f) (function:code tgt))
	  (throw 'ffound path)
	  (let ((v (function:vals f)))
	    (for 0 (1- (length v))
		 (lambda (i) (if (closure? (aref v i))
				 (find-in-f (aref v i) tgt path))))))))
  (define (fn-name f e)
    (let ((p (catch 'ffound
		    (begin
		      (for-each (lambda (topfun)
				  (find-in-f topfun f ()))
				e)
		      #f))))
      (if p
	  (symbol (string.join (map string (reverse! p)) "/"))
	  'lambda)))
  (let ((st (reverse! (list-tail st (if *interactive* 5 4))))
	(e (filter closure? (map (lambda (s) (and (bound? s)
						  (top-level-value s)))
				 (environment))))
	(n 0))
    (for-each
     (lambda (f)
       (princ "#" n " ")
       (print (cons (fn-name (aref f 0) e)
		    (cdr (vector->list f))))
       (newline)
       (set! n (+ n 1)))
     st)))

(define (print-exception e)
  (cond ((and (pair? e)
	      (eq? (car e) 'type-error)
	      (length= e 4))
	 (princ "type error: " (cadr e) ": expected " (caddr e) ", got ")
	 (print (cadddr e)))

	((and (pair? e)
	      (eq? (car e) 'bounds-error)
	      (length= e 4))
	 (princ (cadr e) ": index " (cadddr e) " out of bounds for ")
	 (print (caddr e)))

	((and (pair? e)
	      (eq? (car e) 'unbound-error)
	      (pair? (cdr e)))
	 (princ "eval: variable " (cadr e) " has no value"))

	((and (pair? e)
	      (eq? (car e) 'error))
	 (princ "error: ")
	 (apply princ (cdr e)))

	((and (pair? e)
	      (eq? (car e) 'load-error))
	 (print-exception (caddr e))
	 (princ "in file " (cadr e)))

	((and (list? e)
	      (length= e 2))
	 (print (car e))
	 (princ ": ")
	 (let ((msg (cadr e)))
	   ((if (or (string? msg) (symbol? msg))
		princ print)
	    msg)))

	(else (princ "*** Unhandled exception: ")
	      (print e)))

  (princ *linefeed*))

(define (simple-sort l)
  (if (or (null? l) (null? (cdr l))) l
      (let ((piv (car l)))
	(receive (less grtr)
		 (separate (lambda (x) (< x piv)) (cdr l))
		 (nconc (simple-sort less)
			(list piv)
			(simple-sort grtr))))))

(define (make-system-image fname)
  (let ((f (file fname :write :create :truncate))
	(excludes '(*linefeed* *directory-separator* *argv* that
			       *print-pretty* *print-width* *print-readably*
			       *print-level* *print-length* *os-name*)))
    (with-bindings ((*print-pretty* #t)
		    (*print-readably* #t))
      (let ((syms
	     (filter (lambda (s)
		       (and (bound? s)
			    (not (constant? s))
			    (or (not (builtin? (top-level-value s)))
				(not (equal? (string s) ; alias of builtin
					     (string (top-level-value s)))))
			    (not (memq s excludes))
			    (not (iostream? (top-level-value s)))))
		     (simple-sort (environment)))))
	(write (apply nconc (map list syms (map top-level-value syms))) f)
	(io.write f *linefeed*))
      (io.close f))))

; initialize globals that need to be set at load time
(define (__init_globals)
  (if (or (eq? *os-name* 'win32)
	  (eq? *os-name* 'win64)
	  (eq? *os-name* 'windows))
      (begin (set! *directory-separator* "\\")
	     (set! *linefeed* "\r\n"))
      (begin (set! *directory-separator* "/")
	     (set! *linefeed* "\n")))
  (set! *output-stream* *stdout*)
  (set! *input-stream*  *stdin*)
  (set! *error-stream*  *stderr*))

(define (__script fname)
  (trycatch (load fname)
	    (lambda (e) (begin (top-level-exception-handler e)
			       (exit 1)))))

(define (__start argv)
  (__init_globals)
  (if (pair? (cdr argv))
      (begin (set! *argv* (cdr argv))
	     (set! *interactive* #f)
	     (__script (cadr argv)))
      (begin (set! *argv* argv)
	     (set! *interactive* #t)
	     (princ *banner*)
	     (repl)))
  (exit 0))