init.cora

(set 'null? (lambda (x) (= x ())))
(set 'cadr (lambda (x) (car (cdr x))))
(set 'caar (lambda (x) (car (car x))))
(set 'cdar (lambda (x) (cdr (car x))))
(set 'cddr (lambda (x) (cdr (cdr x))))
(set 'caddr (lambda (x) (car (cdr (cdr x)))))
(set 'cadddr (lambda (x) (car (cdr (cdr (cdr x))))))
(set 'cdddr (lambda (x) (cdr (cdr (cdr x)))))
(set 'rcons
     (lambda (exp)
       (if (cons? exp)
           (cons 'cons
                 (cons (car exp)
                       (cons (rcons (cdr exp)) ())))
           ())))
(set 'pair? (lambda (x) (cons? x)))
(set '.reverse-h
     (lambda (res l)
       (if (cons? l)
           (.reverse-h (cons (car l) res) (cdr l))
           res)))
(set 'reverse (.reverse-h ()))
(set 'map-h
     (lambda (res f l)
       (if (cons? l)
           (map-h (cons (f (car l)) res) f (cdr l))
           (reverse res))))
(set 'map (lambda (f l) (map-h () f l)))

;; =============== The macro utilities ============
(set '*macros* ())
(set '*protect-symbol* (gensym 'protect))
(set '.protect (lambda (x)
                (cons *protect-symbol* x)))
(set '.add-to-*macros*
     (lambda (n v)
       (set '*macros* (cons (cons n v) *macros*))))

;; (func macroexpand1-h
;;       [x . y] [(cons m fn) . macros] => (fn [x . y]) where (= m x)
;;       input [_ . macros] => (macroexpand1-h input macros)
;;       input [] => input)

(set '.macroexpand1-h
     (lambda (exp macros)
       (if (= () macros)
           exp
           ((lambda (item)
              (if (if (cons? exp)
                      (if (= (car exp) (car item))
                          true
                        false)
                    false)
                  ((cdr item) exp)
                  (.macroexpand1-h exp (cdr macros))))
            (car macros)))))

(set '.macroexpand1
     (lambda (exp)
       (.macroexpand1-h exp *macros*)))

;; (func macroexpand
;;       ['lambda args body] => ['lambda args (macroexpand body)]
;;       ['quote xx] => xx
;;       (cons x y) => y where (= x *protect-symbol*)
;;       (cons x y) => (let exp1 (.macroexpand1 (cons x y))
;;                       (if (= exp1 (cons x y))
;;                           (map macroexpand exp1)
;;                           (macroexpand exp1)))
;;       x => x)

(set '.macroexpand-boot
     (lambda (exp)
       (if (cons? exp)
           (if (= (car exp) *protect-symbol*)
               (cdr exp)
             (if (= (car exp) (quote lambda))
                 (cons (quote lambda) (cons (cadr exp) (cons (.macroexpand-boot (caddr exp)) ())))
               (if (= (car exp) (quote quote))
                   exp
                 ((lambda (exp1)
                    (if (= exp1 exp)
                        (map .macroexpand-boot exp1)
                      (.macroexpand-boot exp1)))
                  (.macroexpand1 exp)))))
         exp)))

(set 'macroexpand .macroexpand-boot)

;; (func defmacro-macro
;;       ['defmacro name arg body] => ['.add-to-*macros* ['quote name] ['lambda arg body]])

(set 'defmacro-macro
     (lambda (exp)
       (cons '.add-to-*macros*
             (cons (cons 'quote (cons (cadr exp) ()))
                   (cons (cons 'lambda (cons (caddr exp) (cdddr exp))) ())))))

(.add-to-*macros* 'defmacro defmacro-macro)
(.add-to-*macros* 'list (lambda (exp) (rcons (cdr exp))))

(defmacro defun (exp)
  (list 'set (list 'quote (cadr exp))
        (list 'lambda (caddr exp)
              (cadddr exp))))

(defun elem? (x l)
  (if (cons? l)
      (if (= (car l) x)
          true
          (elem? x (cdr l)))
      false))

(defun atom? (x) (not (cons? x)))

;; (defun .rewrite-let (params args exp)
;;   (if (null? (cdr exp))
;;       (cons (list 'lambda params (car exp)) args)
;;       (.rewrite-let
;;        (cons (car exp) params)
;;        (cons (cadr exp) args)
;;        (cddr exp))))

;; (defmacro let (exp)
;;   (.rewrite-let () () (cdr exp)))

(defun .rewrite-let (exp)
  (if (null? (cdr exp))
      (car exp)
      (cons 'let
	    (cons (car exp)
		  (cons (cadr exp)
			(cons (.rewrite-let (cddr exp)) ()))))))

(defmacro let (exp)
  (.rewrite-let (cdr exp)))

(defmacro cond (exp)
  (if (= () (cdr exp))
      (list 'error "no cond match")
    (let curr (cadr exp)
         (list 'if (car curr)
               (cadr curr)
               (cons 'cond (cddr exp))))))

(defun .rewrite-or (l)
  (if (= l ())
      false
    (if (= (car l) true)
        true
      (let more (.rewrite-or (cdr l))
           (if (= more true)
               true
             (list 'if (car l) true more))))))

(defmacro or (exp)
  (.rewrite-or (cdr exp)))

(defun .rewrite-and (l)
  (if (= () l)
      true
    (if (= (car l) false)
        false
      (let more (.rewrite-and (cdr l))
           (if (= more false)
               false
             (list 'if (car l) more false))))))

(defmacro and (exp)
  (.rewrite-and (cdr exp)))

(defun boolean? (x) (or (= x true) (= x false)))

(defun .rcons1 (pat)
  (if (null? (cdr pat))
      (car pat)
      (list 'cons (car pat) (.rcons1 (cdr pat)))))

(defmacro list-rest (exp)
  (.rcons1 (cdr exp)))

;; =============== pattern match utilities =================

(defun .match-cons-expander (pat expr body cc)
  (let x (cadr pat)
       y (caddr pat)
       (if (and (cons? expr)
		(= (car expr) 'cons))
	   (let e1 (cadr expr)
		e2 (caddr expr)
		(.match1 x e1
			 (.match1 y e2 body cc) cc))
	   (list 'if (list 'cons? expr)
		 (.match1 x (list 'car expr)
			  (.match1 y (list 'cdr expr)
				   body
				   cc)
			  cc)
		 (cons cc ())))))

(defun .match1 (pat expr body cc)
  (let literal? (lambda (x) (and (atom? x) (not (symbol? x))))
       (cond
	 ((literal? pat) (if (= pat expr) body
			     (list 'if (list '= pat expr) body (list cc))))
	 ((symbol? pat) (list 'let pat expr body))
	 ((pair? pat) (cond
			((= (car pat) 'quote) (list 'if (list '= pat expr) body (list cc)))
			((= (car pat) 'cons) (.match-cons-expander pat expr body cc))))
	 (true (error (str "match fail " pat))))))

(defun .extract-rule-action (rules cc)
  (let action (car (cdr rules))
    (if (and (pair? action)
             (= (car action) 'where))
        (list 'if (cadr action)
              (caddr action)
              (list cc))
        action)))

(defun .match-helper (value rules)
  (cond
    ((null? rules) (list 'error "no match-help found!"))
    ((and (pair? rules) (pair? (cdr rules)))
     (let pat (car rules)
	  cc (gensym 'cc)
	  (let action (.extract-rule-action rules cc)
	       (let curr (.match1 (macroexpand pat) value action cc)
		    rest (.match-helper value (cdr (cdr rules)))
		    (list 'let cc (list 'lambda () rest)
			  curr)))))))

(defun .rewrite-match (exp)
  (let value (macroexpand (cadr exp))
       rules (cddr exp)
       (if (and (cons? value)
		(not (= 'cons (car value))))
	   (let val (gensym 'val)
		(list 'let val value (.match-helper val rules)))
	   (.match-helper value rules))))


(defmacro match (exp)
  (.rewrite-match exp))

;; ================ the func macro ======================
(defun .extract-rules1 (input current result)
  (match input
    ()	(reverse result)
    (list-rest '=> act 'where pred remain)
    (let pat (cons 'list (reverse current))
      (.extract-rules1 remain () (cons (list 'where pred act) (cons pat result))))
    (list-rest '=> act remain)
    (let pat (cons 'list (reverse current))
      (.extract-rules1 remain () (cons act (cons pat result))))
    (cons x y)	(.extract-rules1 y (cons x current) result)))

(defun .extract-rules (input)
  (.extract-rules1 input () ()))

(defun .rules-patterns (res rules)
  (if (null? rules)
      (reverse res)
      (.rules-patterns (cons (car rules) res) (cddr rules))))

(defun .length-h (i l)
  (if (= l ())
      i
      (.length-h (+ i 1) (cdr l))))

(defun length (l)
  (.length-h 0 l))

(defun .filter-h (res fn l)
  (if (cons? l)
      (if (fn (car l))
          (.filter-h (cons (car l) res) fn (cdr l))
          (.filter-h res fn (cdr l)))
      (reverse res)))

(defun filter (fn l)
  (.filter-h () fn l))

(defun append (l1 l2)
       (if (= l1 ())
           l2
           (cons (car l1) (append (cdr l1) l2))))

(defun .rules-arg-count (rules)
  (let pats (.rules-patterns () rules)
    len (lambda (x) (length (cdr x)))
    (let counts (map len pats)
      (let n (car counts)
        (let dif (lambda (x) (not (= n x)))
          (if (not (null? (filter dif (cdr counts))))
              (error "inconsistent func rule args count")
              n))))))

(defun .gen-parameters (n)
  (if (= n 0)
      ()
      (cons (gensym 'p) (.gen-parameters (- n 1)))))

(defmacro func (exp)
  (let body (.extract-rules (cddr exp))
    (let nargs (.rules-arg-count body)
      (let args (.gen-parameters nargs)
        (list 'defun (cadr exp) args
              (cons 'match (cons (cons 'list args)
                                 body)))))))

;; (func cora:walk
;;       f [x . y] => (f (map (cora:walk f) [x . y]))
;;       f x => (f x))

(func .propagate-boolean0
      ['car ['cons x _]] => x
      ['cdr ['cons _ x]] => x
      ['cons? ['cons _ _]] => true
      ['and true true] => true
      ['null? ()] => true
      ['null? ['cons _ _]] => false
      ['not true] => false
      ['not false] => true
      ['if true y z] => y
      ['if false y z] => z
      x => x)

(func .propagate-boolean
      ['quote x] => ['quote x]
      ['cons? x] => (let x1 (.propagate-boolean x)
		       (.propagate-boolean0 ['cons? x1]))
      ['car x] => (let x1 (.propagate-boolean x)
		       (.propagate-boolean0 ['car x1]))
      ['cdr x] => (let x1 (.propagate-boolean x)
		       (.propagate-boolean0 ['cdr x1]))
      ['and x y] => (let x1 (.propagate-boolean x)
			 y1 (.propagate-boolean y)
			 (.propagate-boolean0 ['and x1 y1]))
      ['null? x] => (let x1 (.propagate-boolean x)
			 (.propagate-boolean0 ['null? x1]))
      ['not x] => (let x1 (.propagate-boolean x)
		       (.propagate-boolean0 ['not x1]))
      ['if x y z] => (let x1 (.propagate-boolean x)
			  y1 (.propagate-boolean y)
			  z1 (.propagate-boolean z)
			  (.propagate-boolean0 ['if x1 y1 z1]))
      ['lambda args body] => ['lambda args (.propagate-boolean body)]
      [f . args] => (map .propagate-boolean [f . args])
      x => x)

(defun macroexpand (exp)
  (.propagate-boolean (.macroexpand-boot exp)))

;; ===============

;; begin x y z ...
;; (do x (do y z))
(func .rewrite-begin
      [x] => x
      [x y] => ['do x y]
      [x . y] => ['do x (.rewrite-begin y)])

(defmacro begin (exp)
  (.rewrite-begin (cdr exp)))

(func .rewrite-backquote
      x => ['quote x] where (symbol? x)
      ['unquote x] => x
      [x . more] => ['list . (map .rewrite-backquote [x . more])]
      x => x)
      
(defmacro backquote (exp)
  (.rewrite-backquote (cadr exp)))