init.cora

;; this file does not use define-library deliberately
;; if we use it, we need to either append cora/init# prefix in C or write car as (value 'car) here
;; if we do not use it, there are some duplicated definitions, both cadr and cora/init#cadr exist

(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 'cora/init#reverse-h
     (lambda (res l)
       (if (cons? l)
           (cora/init#reverse-h (cons (car l) res) (cdr l))
           res)))
(set 'reverse (cora/init#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 'cora/init#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 'cora/init#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)
                  (cora/init#macroexpand1-h exp (cdr macros))))
            (car macros)))))

(set 'cora/init#macroexpand1
     (lambda (exp)
       (cora/init#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 (cora/init#macroexpand1 (cons x y))
;;                       (if (= exp1 (cons x y))
;;                           (map macroexpand exp1)
;;                           (macroexpand exp1)))
;;       x => x)

(set 'cora/init#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 (cora/init#macroexpand-boot (caddr exp)) ())))
               (if (= (car exp) (quote quote))
                   exp
                 ((lambda (exp1)
                    (if (= exp1 exp)
                        (map cora/init#macroexpand-boot exp1)
                      (cora/init#macroexpand-boot exp1)))
                  (cora/init#macroexpand1 exp)))))
         exp)))

(set 'macroexpand cora/init#macroexpand-boot)

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

(set 'defmacro-macro
     (lambda (exp)
       (cons 'cora/init#add-to-*macros*
             (cons (cons 'quote (cons (cadr exp) ()))
                   (cons (cons 'lambda (cons (caddr exp) (cdddr exp))) ())))))

(cora/init#add-to-*macros* 'defmacro defmacro-macro)
(cora/init#add-to-*macros* 'list (lambda (exp) (rcons (cdr exp))))

(defmacro defun (exp)
  (list 'def (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 cora/init#rewrite-let (exp)
  (if (null? (cdr exp))
      (car exp)
      (cons 'let
	    (cons (car exp)
		  (cons (cadr exp)
			(cons (cora/init#rewrite-let (cddr exp)) ()))))))

(defmacro let (exp)
  (cora/init#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 cora/init#rewrite-or (l)
  (if (= l ())
      false
    (if (= (car l) true)
        true
      (let more (cora/init#rewrite-or (cdr l))
           (if (= more true)
               true
             (list 'if (car l) true more))))))

(defmacro or (exp)
  (cora/init#rewrite-or (cdr exp)))

(defun cora/init#rewrite-and (l)
  (if (= () l)
      true
    (if (= (car l) false)
        false
      (let more (cora/init#rewrite-and (cdr l))
           (if (= more false)
               false
             (list 'if (car l) more false))))))

(defmacro and (exp)
  (cora/init#rewrite-and (cdr exp)))

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

(defun cora/init#rcons1 (pat)
  (if (null? (cdr pat))
      (car pat)
      (list 'cons (car pat) (cora/init#rcons1 (cdr pat)))))

(defmacro list-rest (exp)
  (cora/init#rcons1 (cdr exp)))

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

(defun cora/init#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)
		(cora/init#match1 x e1
			 (cora/init#match1 y e2 body cc) cc))
	   (list 'if (list 'cons? expr)
		 (cora/init#match1 x (list 'car expr)
			  (cora/init#match1 y (list 'cdr expr)
				   body
				   cc)
			  cc)
		 (cons cc ())))))

(defun cora/init#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) (cora/init#match-cons-expander pat expr body cc))))
	 (true (error (str "match fail " pat))))))

(defun cora/init#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 cora/init#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 (cora/init#extract-rule-action rules cc)
	       (let curr (cora/init#match1 (macroexpand pat) value action cc)
		    rest (cora/init#match-helper value (cdr (cdr rules)))
		    (list 'let cc (list 'lambda () rest)
			  curr)))))))

(defun cora/init#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 (cora/init#match-helper val rules)))
	   (cora/init#match-helper value rules))))


(defmacro match (exp)
  (cora/init#rewrite-match exp))

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

(defun cora/init#extract-rules (input)
  (cora/init#extract-rules1 input () ()))

(defun cora/init#rules-patterns (res rules)
  (if (null? rules)
      (reverse res)
      (cora/init#rules-patterns (cons (car rules) res) (cddr rules))))

(defun cora/init#length-h (i l)
  (if (= l ())
      i
      (cora/init#length-h (+ i 1) (cdr l))))

(defun length (l)
  (cora/init#length-h 0 l))

(defun cora/init#filter-h (res fn l)
  (if (cons? l)
      (if (fn (car l))
          (cora/init#filter-h (cons (car l) res) fn (cdr l))
          (cora/init#filter-h res fn (cdr l)))
      (reverse res)))

(defun filter (fn l)
  (cora/init#filter-h () fn l))

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

(defun cora/init#rules-arg-count (rules)
  (let pats (cora/init#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 cora/init#gen-paramenters (n)
  (if (= n 0)
      ()
      (cons (gensym 'p) (cora/init#gen-paramenters (- n 1)))))

(defmacro func (exp)
  (let body (cora/init#extract-rules (cddr exp))
    (let nargs (cora/init#rules-arg-count body)
      (let args (cora/init#gen-paramenters nargs)
        (list 'defun (cadr exp) args
              (cons 'match (cons (cons 'list args)
                                 body)))))))

(func cora/init#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 cora/init#propagate-boolean
      ['quote x] => ['quote x]
      ['cons? x] => (let x1 (cora/init#propagate-boolean x)
		       (cora/init#propagate-boolean0 ['cons? x1]))
      ['car x] => (let x1 (cora/init#propagate-boolean x)
		       (cora/init#propagate-boolean0 ['car x1]))
      ['cdr x] => (let x1 (cora/init#propagate-boolean x)
		       (cora/init#propagate-boolean0 ['cdr x1]))
      ['and x y] => (let x1 (cora/init#propagate-boolean x)
			 y1 (cora/init#propagate-boolean y)
			 (cora/init#propagate-boolean0 ['and x1 y1]))
      ['null? x] => (let x1 (cora/init#propagate-boolean x)
			 (cora/init#propagate-boolean0 ['null? x1]))
      ['not x] => (let x1 (cora/init#propagate-boolean x)
		       (cora/init#propagate-boolean0 ['not x1]))
      ['if x y z] => (let x1 (cora/init#propagate-boolean x)
			  y1 (cora/init#propagate-boolean y)
			  z1 (cora/init#propagate-boolean z)
			  (cora/init#propagate-boolean0 ['if x1 y1 z1]))
      ['lambda args body] => ['lambda args (cora/init#propagate-boolean body)]
      [f . args] => (map cora/init#propagate-boolean [f . args])
      x => x)

(defun macroexpand (exp)
  (cora/init#propagate-boolean (cora/init#macroexpand-boot exp)))

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

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

(defmacro begin (exp)
  (cora/init#rewrite-begin (cdr exp)))

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

;; ============= define-library ============

(func cora/init#parse-define-library-h
      [['import lib] . rest] imports exports k => (cora/init#parse-define-library-h rest (cons lib imports) exports k)
      [['export . more] . rest]  imports exports k => (cora/init#parse-define-library-h rest imports more k)
      body imports exports k => (k (reverse imports) exports body))

(defun cora/init#parse-define-library (data k)
  (cora/init#parse-define-library-h data () () k))

(defmacro define-library (sexp)
  (let path (cadr sexp)
       ((cora/init#parse-define-library (cddr sexp))
	(lambda (import export body)
	  ['ns path (cons "cora/init" import)
	  (cons 'begin (append (map (lambda (imp) ['import imp]) import)
			  [['def '*ns-export* ['backquote export]] . body]))]))))

(set 'cora/init#*ns-export* `(cadr caar cdar cddr caddr cadddr cdddr pair? atom?
				   boolean? number? null?
				   string-append
				   intern symbol->string
				   vector vector-set! vector-ref vector-length
				   bytes bytes-length
				   read-file-as-sexp
				   value value-or
				   apply load-so import load
				   try throw
				   reverse map macroexpand elem?  length filter append))

(set 'cora/init#cadr cadr)
(set 'cora/init#caar caar)
(set 'cora/init#cdar cdar)
(set 'cora/init#cddr cddr)
(set 'cora/init#caddr caddr)
(set 'cora/init#cadddr cadddr)
(set 'cora/init#cdddr cdddr)
(set 'cora/init#pair? pair?)
(set 'cora/init#atom? atom?)
(set 'cora/init#boolean? boolean?)
(set 'cora/init#null? null?)
(set 'cora/init#number? number?)
(set 'cora/init#string-append string-append)
(set 'cora/init#intern intern)
(set 'cora/init#symbol->string symbol->string)
(set 'cora/init#vector vector)
(set 'cora/init#vector-set! vector-set!)
(set 'cora/init#vector-ref vector-ref)
(set 'cora/init#vector-length vector-length)
(set 'cora/init#bytes bytes)
(set 'cora/init#bytes-length bytes-length)
(set 'cora/init#value value)
(set 'cora/init#value-or value-or)
(set 'cora/init#read-file-as-sexp read-file-as-sexp)
(set 'cora/init#apply apply)
(set 'cora/init#load load)
(set 'cora/init#load-so load-so)
(set 'cora/init#import import)
(set 'cora/init#try try)
(set 'cora/init#throw throw)
(set 'cora/init#reverse reverse)
(set 'cora/init#map map)
(set 'cora/init#macroexpand macroexpand)
(set 'cora/init#elem? elem?)
(set 'cora/init#length length)
(set 'cora/init#filter filter)
(set 'cora/init#append append)