;-----------------------------------------------------------------------
; predefined.scm
; David Boozer
; 19 January 2009
;-----------------------------------------------------------------------
; Some useful functions and special forms.
;-----------------------------------------------------------------------

(define first car)

(define second (lambda (x) (car (cdr x))))

(define third (lambda (x) (car (cdr (cdr x)))))

(define fourth (lambda (x) (car (cdr (cdr (cdr x))))))

(define list (lambda x x))

(define null? (lambda (sexp) (eqv? sexp ())))

(define eval-cond
  (lambda (sexp env)
    (if (null? sexp) ()
	(if (eval (first (first sexp)) env)
	    (eval (second (first sexp)) env)
	    (eval-cond (cdr sexp) env)))))

(define cond (special eval-cond))

(define and
  (lambda x
    (cond ((null? x) #t)
	  ((car x) (apply and (cdr x)))
	  (#t #f))))

(define or
  (lambda x
    (cond ((null? x) #f)
	  ((car x) #t)
	  (#t (apply or (cdr x))))))

(define not (lambda (x) (if x #f #t)))

(define list? (lambda (sexp) (or (null? sexp) (= (type-of sexp) 0))))

(define number? (lambda (sexp) (= (type-of sexp) 1)))

(define symbol? (lambda (sexp) (= (type-of sexp) 2)))

(define append
  (lambda (x y) (if (null? x) y (cons (car x) (append (cdr x) y)))))

(define map
  (lambda (f lst)
    (if (null? lst) () (cons (f (car lst)) (map f (cdr lst))))))

; (pair '(a b c) '(1 2 3)) --> ((a . 1) (b . 2) (c . 3))
(define pair
  (lambda (lst1 lst2)
    (if (null? lst1) ()
	(cons (cons (car lst1) (car lst2))
	      (pair (cdr lst1) (cdr lst2))))))

(define eval-list
  (lambda (lst env)
    (map (lambda (x) (eval x env)) lst)))

(define eval-let
  (lambda (sexp env)
    (eval (second sexp)
	  (append (pair (map first (first sexp))
			(eval-list (map second (first sexp)) env))
		  env))))

(define let (special eval-let))

(define current-env (special (lambda (sexp env) env)))

(define equal?
  (lambda (x y)
    (cond ((or (null? x) (null? y)) (eqv? x y))
	  ((and (list? x) (list? y))
	   (and (equal? (car x) (car y))
		(equal? (cdr x) (cdr y))))
	  (#t (eqv? x y)))))

(define length (lambda (x) (if (null? x) 0 (+ 1 (length (cdr x))))))

(define eval-top (lambda (x) (eval x ())))

; McCarthy's label special form

(define eval-label
  (lambda (sexp env)
    (let ((name (first sexp))
	  (f (second sexp))
	  (g (lambda x (apply (eval-label sexp env) x))))
      (eval f (cons (cons name g) env)))))

(define label (special eval-label))