(in-package "CL-USER")

(setf *global-const-list* nil)

(defun zip (fn l1 l2)
  (cond ((or (null l1) (null l2)) nil)
        (t (cons (funcall fn (car l1) (car l2)) (zip fn (cdr l1) (cdr l2))))))


(defun fold (fn start lis)
  (cond ((null lis) start)
        (t (funcall fn (car lis) (fold fn start (cdr lis))))))

(defun findl (elm lis)
  (cond ((null lis) nil)
        ((eql elm (car lis)) lis)
        (t (findl elm (cdr lis)))))

(defun enumerate (lis strt)
  (cond ((null lis) nil)
        (t (cons (cons (car lis) strt) (enumerate (cdr lis) (+ 1 strt)))))) 

(defun length=2 (lis)
  (and (consp lis) (not (null (cdr lis))) (null (cddr lis))))

(defun length=1 (lis)
  (and (consp lis) (null (cdr lis))))

;

(defun show-error (&rest lis)
  (let ()
    (format t "error: " )
    (mapcar #'(lambda (z) (format t "~S" z)) lis)))



;

(defparameter *system-list*
  '(
    (%make-closure 2 (get-word 200 0))
    (%make-vector 1 (get-word 200 4))
    (%reserve-space 1 (get-word 200 8))
    (%cons 2 (get-word 200 12))
    ))



(defparameter *primitive-list* 
'(

;cons car cdr 

car

cdr

;eq

;set-car set-cdr consp listp null

;make-string char set-char stringp

;make-vector svref set-svref arrayp


%svref
%set-svref

%set-symbol-function
%symbol-function

%set-symbol-value
%symbol-value

%closure-ref

%print
%read

do-until


;make-symbol intern
;symbol-name symbol-value symbol-function symbol-plist
;set-symbol-value set-symbol-function set-symbol-plist 
;symbolp

;char-code
;code-char
;characterp

apply
funcall

vector

get-byte
set-byte

get-word
set-word

get-dsp
get-csp

get-a-index-pp
set-b-index-pp

set-a
set-b

get-status
set-status


p-align3

p-constr
p-add

;p-shiftl-1
;p-shiftr-1

p-shiftl
p-shiftr

get-info

tag-and
tag-ior
tag-xor

tag-eq
get-tag
tag-set

addr-eq
addr-eqi
addr-and
addr-ior
get-addr

dec-sp

%+ %-

;%* 

;%div %rem 

%<= %>= %< %> %= 

;%/=

))


(let ((system-list-heads (mapcar #'car *system-list*)))
  (defun is-system (form)
    (member (car form) system-list-heads))

  (defun sysfun-arity (head)
    (let ((res (member head *system-list* :key #'car)))
      (if res
          (cadr (car res))
        nil)))

  (defun sysfun-head (head)
    (let ((res (member head *system-list* :key #'car)))
      (if res
          (caddr (car res))
        nil))))

(defun is-primitive (form)
  (member (car form) *primitive-list*))



(defun make-let (vars vals body)
  (cons 'let (cons (zip #'(lambda (x y) (list x y)) vars vals) body)))

(defun make-let* (vars vals body)
  (cons 'let* (cons (zip #'(lambda (x y) (list x y)) vars vals) body)))

(defun let-vars (e)
  (cadr e))

(defun let-body (e)
  (cddr e))


(defun progn-ify (e)
  (if (is-progn e)
      e
    (cons 'progn e)))



(defun is-lambda (form)
  (and (consp form) (eq (car form) 'lambda)))

(defun make-lambda (vars body)
  (cons 'lambda (cons vars body)))

(defun lambda-vars (form)
  (cadr (un-annotate form)))

(defun lambda-body (form)
  (cddr (un-annotate form)))


(defun if-expr-tst (e)
  (cadr e))

(defun if-expr-branch-t (e)
  (caddr e))

(defun if-expr-branch-f (e)
  (cadddr e))

(defun if-expr-has-3 (e)
  (not (null (cdddr e))))







(defun is-labels (form)
  (eq (car form) 'labels))

(defun make-labels-lambda (funs fun-lambdas body)
  (cons 'labels 
        (cons
         (zip #'(lambda (x y) (annotate (list x (lambda-vars y) (car (lambda-body y))) (get-annotate y)))
              funs fun-lambdas)
        body)))

(defun labels-body (form)
  (cddr form))




(defparameter *special-form-list* '(progn if cond quote function values multiple-value-bind)) 

(defun is-form (form)
  (symbolp (car form)))

(defun is-special-form (form)
  (member (car form) *special-form-list*))

(defun is-if (form)
  (and (listp form) (eq (car form) 'if)))

(defun is-progn (form)
  (and (listp form) (eq (car form) 'progn)))

(defun is-setq (form)
  (and (listp form) (eq (car form) 'setq)))

(defun is-quote (form)
  (and (listp form) (eq (car form) 'quote)))

(defun is-function (form)
  (and (listp form) (eq (car form) 'function)))

(defun is-defun (form)
  (and (listp form) (eq (car form) 'defun)))

(defun is-do-until (form)
  (and (listp form) (eq (car form) 'do-until)))

(defun is-form-with-head (form head)
  (and (listp form) (eq (car form) head)))


(defun un-annotate (form)
  (if (and (listp form) (eq (car (cadr form)) '&&annotate))
      (cons (car form) (cddr form))
    form))

(defun get-annotate (form)
  (if (and (listp form) (eq (car (cadr form)) '&&annotate))
      (cadr (cadr form))
    nil))

(defun annotate (form val)
  (if (null val)
      form
    (let ((form-1 (un-annotate form)))
      (cons (car form-1) (cons (list '&&annotate val) (cdr form-1))))))

(defun annotate-prop (form prop)
  (let ((ann (get-annotate form)))
    (if ann
        (let ()
          (setf ann (findl prop ann))
          (if ann
              (cadr ann)
            nil))
      nil)))



(defun get-form (e)
  (car e))

(defun get-aux (e)
  (cadr e))



(defun is-power-of-two (n)
  (and (numberp n) (>= n 0) (= (logcount n) 1)))