565 lines
20 KiB
Common Lisp
565 lines
20 KiB
Common Lisp
(require 'util "util.lisp")
|
||
(require 'match "match.lisp")
|
||
|
||
;; `
|
||
(defvar my-quasiquote nil);(car '`(,a)))
|
||
|
||
;; ,
|
||
(defvar my-unquote nil);(caaadr '`(,a)))
|
||
|
||
;; ,@
|
||
(defvar my-unquote-unsplice nil);(caaadr '`(,@a)))
|
||
|
||
(declaim (ftype function lisp2li)) ;; Double récursion map-lisp2li / lisp2li.
|
||
(defun map-lisp2li (expr env)
|
||
(mapcar (lambda (x) (lisp2li x env)) expr))
|
||
|
||
(declaim (ftype function make-stat-env1)) ;; Double récursion make-stat-env1 / make-stat-env-optional
|
||
(defun make-stat-env-optional (params env position num-env)
|
||
(cond ((endp params)
|
||
env)
|
||
((consp (car params))
|
||
`((,(caar params) ,num-env ,position)
|
||
(,(intern (format nil "~a-P" (caar params))) ,num-env ,(+ 1 position))
|
||
. ,(make-stat-env-optional (cdr params) env (+ 2 position) num-env)))
|
||
((eq '&rest (car params))
|
||
(make-stat-env1 (cdr params) env position num-env))
|
||
(T
|
||
`((,(car params) ,num-env ,position)
|
||
. ,(make-stat-env-optional (cdr params) env (+ 1 position) num-env)))))
|
||
|
||
(defun env-depth (env)
|
||
(or (cadar (last env)) 0))
|
||
|
||
(defun recalculation (env)
|
||
(cond ((endp env)
|
||
env)
|
||
(T
|
||
`((,(caar env) ,(+ 1 (cadar env)) ,(caddar env))
|
||
. ,(recalculation (cdr env))))))
|
||
|
||
(defun make-stat-env1 (params &optional env (position 1) num-env)
|
||
(cond ((endp params)
|
||
env)
|
||
((eq '&optional (car params))
|
||
(make-stat-env-optional (cdr params) env position num-env))
|
||
((eq '&rest (car params))
|
||
(make-stat-env1 (cdr params) env position num-env))
|
||
(T
|
||
`((,(car params) 0 ,position)
|
||
. ,(make-stat-env1 (cdr params) env (+ 1 position) num-env)))))
|
||
|
||
(defun make-stat-env (params &optional env (position 1))
|
||
(make-stat-env1 params (recalculation env) position 0))
|
||
|
||
(defun transform-quasiquote (expr)
|
||
(cond
|
||
;; a
|
||
((atom expr)
|
||
`',expr)
|
||
;; (a)
|
||
((atom (car expr))
|
||
`(cons ',(car expr)
|
||
,(transform-quasiquote (cdr expr))))
|
||
;; (,a)
|
||
((eq my-unquote (caar expr))
|
||
`(cons ,(cadar expr)
|
||
,(transform-quasiquote (cdr expr))))
|
||
;; (,@a)
|
||
((eq my-unquote-unsplice (caar expr))
|
||
(if (endp (cdr expr))
|
||
(cadar expr)
|
||
`(append ,(cadar expr)
|
||
,(transform-quasiquote (cdr expr)))))
|
||
;; ((a ...) ...)
|
||
(T
|
||
`(cons ,(transform-quasiquote (car expr))
|
||
,(transform-quasiquote (cdr expr))))))
|
||
|
||
(defun get-nb-params-t (params r)
|
||
(cond ((endp params)
|
||
r)
|
||
((or (eq '&optional (car params))
|
||
(eq '&rest (car params)))
|
||
(get-nb-params-t (cdr params) r))
|
||
(T
|
||
(get-nb-params-t (cdr params) (+ 1 r)))))
|
||
|
||
(defun get-nb-params (params)
|
||
"Renvoie le nombre exact de paramètres sans les &optional et &rest"
|
||
(get-nb-params-t params 0))
|
||
|
||
(defun implicit-progn (expr)
|
||
(if (n-consp 2 expr)
|
||
(cons 'progn expr)
|
||
(car expr)))
|
||
|
||
|
||
(defun simplify (li) ;; TODO : a finir
|
||
(cond-match li
|
||
((:nil :progn :expr _)
|
||
(simplify expr))
|
||
((:nil :progn :body0 _* (:nil :progn :body1 _*)+ :body2 _*)
|
||
(simplify `(:progn ,@body0 ,@(car body1) ,@body2)))
|
||
((:nil :progn :body0 _* (:nil :let :size (? integerp) :body1 _*)+ :body2 _*)
|
||
(simplify `(:let ,@size ,@body0 ,@(car body1) ,@body2)))
|
||
((:nil :let :size1 (? integerp) :body1 _*
|
||
(:nil :let :size2 (? integerp)
|
||
(:nil :set-var (:depth-set (? integerp) :index-set (? integerp)) @.)+
|
||
:var1 (:nil :cvar :depth1 (? integerp) :index1 (? integerp))*
|
||
:body2 _* :var2 (:nil :cvar :depth2 (? integerp) :index2 (? integerp))*)
|
||
:body3 _*)
|
||
(simplify `(:let ,(+ size1 size2)
|
||
,@body1
|
||
,@(mapcar
|
||
(lambda (depth index)
|
||
`(:cvar ,(- depth 1) ,(+ index size1))) depth1 index1)
|
||
,@body2
|
||
,@(if (and depth2 index2)
|
||
(mapcar
|
||
(lambda (depth index)
|
||
`(:cvar ,(- depth 1) ,(+ index size1))) depth2 index2))
|
||
,@body3)))
|
||
((:nil :let :body0 _* (:nil :progn :body1 _*)+ :body2 _*)
|
||
(simplify `(:let ,@body0 ,@(car body1) ,@body2)))
|
||
((:nil :let :size1 (? integerp) :body0 _* (:nil :let :size2 (? integerp) :body1 _*)+ :body2 _*)
|
||
(simplify `(:let ,(+ size1 (car size2)) ,@body0 ,@(car body1) ,@body2)))
|
||
((:nil :if (:nil :const :cond . _) :then @. :else @.)
|
||
(simplify (if cond then else)))
|
||
(@. li)))
|
||
|
||
(defun lisp2li (expr &optional env)
|
||
"Convertit le code LISP en un code intermédiaire reconnu
|
||
par le compilateur et par l’interpréteur"
|
||
(cond
|
||
;; literaux
|
||
((and (atom expr) (constantp expr))
|
||
(cons :const expr))
|
||
;; symboles
|
||
((symbolp expr)
|
||
(let ((cell (assoc expr env)))
|
||
(if cell
|
||
`(:cvar ,(cadr cell) ,(caddr cell))
|
||
(error "Variable ~S unknown" expr))))
|
||
;; lambda solitaire ex: (lambda (x) x)
|
||
((eq 'lambda (car expr)) ;; TODO : ameliorer le cas du lambda
|
||
(if (member '&rest (second expr))
|
||
`(:lclosure . (,(get-nb-params (second expr))
|
||
,(+ 1 (mposition '&rest (second expr)))
|
||
,@(lisp2li (implicit-progn (cddr expr))
|
||
(make-stat-env (second expr) env))))
|
||
`(:lclosure . ,(cons (get-nb-params (second expr))
|
||
(lisp2li (implicit-progn (cddr expr))
|
||
(make-stat-env (second expr) env))))))
|
||
;; lambda ex: ((lambda (x) x) 1)
|
||
((and (consp (car expr))
|
||
(eq 'lambda (caar expr)))
|
||
`(:mcall ,(lisp2li (car expr) env)
|
||
,@(mapcar (lambda (param)
|
||
(lisp2li param env))
|
||
(cdr expr))))
|
||
;; (not-symbol ...)
|
||
((not (symbolp (car expr)))
|
||
(warn "~S isn't a symbol" (car expr)))
|
||
;; fonction meta-definie
|
||
((get (car expr) :defun)
|
||
`(:mcall ,(car expr)
|
||
,@(mapcar (lambda (x) (lisp2li x env)) (cdr expr))))
|
||
;; macro meta-definie
|
||
((get (car expr) :defmacro)
|
||
`(:mcall ,(car expr)
|
||
,@(mapcar (lambda (x) `(:const . ,x)) (cdr expr))))
|
||
;; fonction inconnue
|
||
((and (not (fboundp (car expr)))
|
||
(not (get (car expr) :defun))
|
||
(not (get (car expr) :defmacro)))
|
||
`(:unknown ,expr ,env))
|
||
;; if
|
||
((eq 'if (car expr))
|
||
(list :if
|
||
(lisp2li (second expr) env)
|
||
(lisp2li (third expr) env)
|
||
(lisp2li (fourth expr) env)))
|
||
;; quote
|
||
((eq 'quote (car expr))
|
||
(cons :const (second expr)))
|
||
;; quasiquote `
|
||
((eq my-quasiquote (car expr))
|
||
(lisp2li (transform-quasiquote (cadr expr)) env))
|
||
;; #'fn (FUNCTION fn)
|
||
((eq 'function (car expr))
|
||
`(:sclosure ,(cadr expr)))
|
||
;; let
|
||
((eq 'let (car expr))
|
||
(match (let :bindings ((:names $ :values _)*) :body _*) expr
|
||
(let ((new-env (make-stat-env names env)))
|
||
`(:let ,(length bindings)
|
||
,@(mapcar
|
||
(lambda (name value)
|
||
(let ((cell (assoc name new-env)))
|
||
`(:set-var (,(second cell) ,(third cell))
|
||
,(lisp2li value new-env))))
|
||
names values)
|
||
,(lisp2li (implicit-progn body) new-env)))))
|
||
((eq 'let* (car expr))
|
||
(cond-match expr
|
||
(((? (eq x 'let*)) :bindings () :body _*)
|
||
(lisp2li (implicit-progn body) env))
|
||
(((? (eq x 'let*)) :bindings ((:name $ :value _) :rest ($ _)*) :body _*)
|
||
(lisp2li `(let ((,name ,value))
|
||
(let* ,rest
|
||
,@body)) env))))
|
||
;; defun
|
||
((eq 'defun (car expr))
|
||
`(:mcall set-defun (:const . ,(second expr))
|
||
,(lisp2li `(lambda ,(third expr) ,@(cdddr expr)) env)))
|
||
;; defmacro
|
||
((eq 'defmacro (car expr))
|
||
`(:mcall set-defmacro (:const . ,(second expr))
|
||
,(lisp2li `(lambda ,(third expr) ,@(cdddr expr)) env)))
|
||
;; apply
|
||
((eq 'apply (car expr))
|
||
`(:sapply ,(second expr) ,@(cddr expr)))
|
||
;; setf
|
||
((eq 'setf (car expr))
|
||
(cond ((symbolp (cadr expr))
|
||
(let ((cell (assoc (cadr expr) env)))
|
||
`(:set-var (,(second cell) ,(third cell))
|
||
,(lisp2li (third expr) env))))
|
||
((symbolp (cdadr expr))
|
||
(let ((cell (assoc (cdadr expr) env)))
|
||
`(:set-var (,(second cell) ,(third cell))
|
||
,(third expr))))
|
||
(T
|
||
`(:set-fun ,(caadr expr) ,@(last expr) ,@(cdadr expr)))))
|
||
;; setq
|
||
((eq 'setq (car expr))
|
||
(lisp2li `(setf ,@(cdr expr)) env))
|
||
;; defvar
|
||
((eq 'defvar (car expr))
|
||
(let ((var `(,(cadr expr)
|
||
,(if (eq nil env) 0 (cadar (last env)))
|
||
,(if (eq nil env) 1 (+ (caddar (last env)) 1)))))
|
||
(setf env (append env `(,var)))
|
||
(print env)
|
||
`(:set-var (,(second var) ,(third var))
|
||
,(third expr))))
|
||
;; progn
|
||
((eq 'progn (car expr))
|
||
(cons :progn (map-lisp2li (cdr expr) env)))
|
||
;; declaim
|
||
((eq 'declaim (car expr))
|
||
(cons :const nil))
|
||
;; the
|
||
((eq 'the (car expr))
|
||
(lisp2li (third expr)))
|
||
;; macros
|
||
((macro-function (car expr))
|
||
(lisp2li (macroexpand-1 expr) env))
|
||
;; foctions normales
|
||
((not (special-operator-p (car expr)))
|
||
`(:call ,(first expr) ,@(map-lisp2li (cdr expr) env)))
|
||
(T
|
||
(error "special form not yet implemented ~S" (car expr)))))
|
||
|
||
;; TODO : demander au prof comment corriger (or (= n 0) (= n 1)) qui rend nil car il fait 2 macroexpand 1: (COND ((= N 0)) (T (= N 1))) 2: (LET (#1=#:RESULT-7048) (IF (SETQ #1# (= N 0)) #1# (= N 1))) et 2 vaux nil car n != 0
|
||
|
||
;; Test unitaire
|
||
(require 'test-unitaire "test-unitaire")
|
||
(erase-tests lisp2li)
|
||
|
||
(deftest (lisp2li make-stat-env)
|
||
(make-stat-env '(x y z))
|
||
'((x 0 1) (y 0 2) (z 0 3)))
|
||
|
||
(deftest (lisp2li make-stat-env)
|
||
(make-stat-env '(a b c d))
|
||
'((a 0 1) (b 0 2) (c 0 3) (d 0 4)))
|
||
|
||
(deftest (lisp2li make-stat-env)
|
||
(make-stat-env '(a b) '((x 0 1) (y 0 2)))
|
||
'((a 0 1) (b 0 2) (x 1 1) (y 1 2)))
|
||
|
||
(deftest (lisp2li make-stat-env)
|
||
(make-stat-env '(a b &optional c &rest d))
|
||
'((a 0 1) (b 0 2) (c 0 3) (d 0 4)))
|
||
|
||
(deftest (lisp2li make-stat-env)
|
||
(make-stat-env '(x y &optional (z t)))
|
||
'((x 0 1) (y 0 2) (z 0 3) (z-p 0 4)))
|
||
|
||
;; (deftest (lisp2li simplify :progn)
|
||
;; (simplify '(:progn (:const . 3)))
|
||
;; '(:const . 3))
|
||
|
||
;; (deftest (lisp2li simplify :progn)
|
||
;; (simplify '(:progn (:call list (:const . 1) (:const . 2))))
|
||
;; '(:call list (:const . 1) (:const . 2)))
|
||
|
||
;; (deftest (lisp2li simplify :progn)
|
||
;; (simplify '(:progn (:progn (:const . 3) (:const . 4))))
|
||
;; '(:progn (:const . 3) (:const . 4)))
|
||
|
||
;; (deftest (lisp2li simplify :progn)
|
||
;; (simplify '(:progn (:const . 3) (:const . 4) (:progn (:const . 5) (:const . 6))))
|
||
;; '(:progn (:const . 3) (:const . 4) (:const . 5) (:const . 6)))
|
||
|
||
;; (deftest (lisp2li simplify :progn)
|
||
;; (simplify '(:progn (:const . 1) (:const . 2) (:progn (:const . 3) (:const . 4)) (:const . 5) (:const . 6)))
|
||
;; '(:progn (:const . 1) (:const . 2) (:const . 3) (:const . 4) (:const . 5) (:const . 6)))
|
||
|
||
;; (deftest (lisp2li simplify :progn)
|
||
;; (simplify '(:progn (:const . 1) (:const . 2) (:progn (:const . 3) (:const . 4)) (:const . 5) (:progn (:const . 6) (:const . 7))))
|
||
;; '(:progn (:const . 1) (:const . 2) (:const . 3) (:const . 4) (:const . 5) (:const . 6) (:const . 7)))
|
||
|
||
;; (deftest (lisp2li simplify :let-progn)
|
||
;; (simplify '(:let (:progn (:const . 3) (:const . 4))))
|
||
;; '(:let (:const . 3) (:const . 4)))
|
||
|
||
;; (deftest (lisp2li simplify :let-progn)
|
||
;; (simplify '(:let (:const . 3) (:const . 4) (:progn (:const . 5) (:const . 6))))
|
||
;; '(:let (:const . 3) (:const . 4) (:const . 5) (:const . 6)))
|
||
|
||
;; (deftest (lisp2li simplify :let-progn)
|
||
;; (simplify '(:let (:const . 1) (:const . 2) (:progn (:const . 3) (:const . 4)) (:const . 5) (:const . 6)))
|
||
;; '(:let (:const . 1) (:const . 2) (:const . 3) (:const . 4) (:const . 5) (:const . 6)))
|
||
|
||
;; (deftest (lisp2li simplify :let-progn)
|
||
;; (simplify '(:let (:const . 1) (:const . 2) (:progn (:const . 3) (:const . 4)) (:const . 5) (:progn (:const . 6) (:const . 7))))
|
||
;; '(:let (:const . 1) (:const . 2) (:const . 3) (:const . 4) (:const . 5) (:const . 6) (:const . 7)))
|
||
|
||
;; (deftest (lisp2li simplify :progn-let)
|
||
;; (simplify '(:progn (:let 0 (:const . 3) (:const . 4))))
|
||
;; '(:let 0 (:const . 3) (:const . 4)))
|
||
|
||
;; (deftest (lisp2li simplify :progn-let)
|
||
;; (simplify '(:progn (:let 2 (:const . 3) (:const . 4) (:progn (:const . 5) (:const . 6)))))
|
||
;; '(:let 2 (:const . 3) (:const . 4) (:const . 5) (:const . 6)))
|
||
|
||
;; (deftest (lisp2li simplify :progn-let)
|
||
;; (simplify '(:progn (:const . 1) (:const . 2) (:let 1 (:const . 3) (:const . 4)) (:const . 5) (:const . 6)))
|
||
;; '(:let 1 (:const . 1) (:const . 2) (:const . 3) (:const . 4) (:const . 5) (:const . 6)))
|
||
|
||
;; (deftest (lisp2li simplify :progn-let)
|
||
;; (simplify '(:progn (:const . 1) (:const . 2) (:let 5 (:const . 3) (:const . 4)) (:const . 5) (:progn (:const . 6) (:const . 7))))
|
||
;; '(:let 5 (:const . 1) (:const . 2) (:const . 3) (:const . 4) (:const . 5) (:const . 6) (:const . 7)))
|
||
|
||
;; (deftest (lisp2li simplify :let-let)
|
||
;; (simplify '(:let 1 (:let 1 (:const . 3) (:const . 4))))
|
||
;; '(:let 2 (:const . 3) (:const . 4)))
|
||
|
||
;; (deftest (lisp2li simplify :let-let)
|
||
;; (simplify '(:let 3 (:let 2 (:const . 3) (:const . 4) (:progn (:const . 5) (:const . 6)))))
|
||
;; '(:let 5 (:const . 3) (:const . 4) (:const . 5) (:const . 6)))
|
||
|
||
;; (deftest (lisp2li simplify :let-let)
|
||
;; (simplify '(:let 2 (:const . 1) (:const . 2) (:let 1 (:const . 3) (:const . 4)) (:const . 5) (:const . 6)))
|
||
;; '(:let 3 (:const . 1) (:const . 2) (:const . 3) (:const . 4) (:const . 5) (:const . 6)))
|
||
|
||
;; (deftest (lisp2li simplify :let-let)
|
||
;; (simplify '(:let 5 (:const . 1) (:const . 2) (:let 5 (:const . 3) (:const . 4)) (:const . 5) (:let 2 (:const . 6) (:const . 7))))
|
||
;; '(:let 12 (:const . 1) (:const . 2) (:const . 3) (:const . 4) (:const . 5) (:const . 6) (:const . 7)))
|
||
|
||
;; (deftest (lisp2li simplify :if)
|
||
;; (simplify '(:if (:const . nil) (:call list 1 2 3) (:const . T)))
|
||
;; '(:const . T))
|
||
|
||
;; (deftest (lisp2li simplify :if)
|
||
;; (simplify '(:if (:const . nil) (:progn (:let 2 (:const . 1)) (:const . 2)) (:call list (:const 1 2 3))))
|
||
;; '(:call list (:const 1 2 3)))
|
||
|
||
;; (deftest (lisp2li simplify :if)
|
||
;; (simplify '(:if (:const . nil) (:const . nil) (:progn (:let 2 (:const . 1)) (:const . 2)) ))
|
||
;; '(:let 2 (:const . 1) (:const . 2)))
|
||
|
||
;; (deftest (lisp2li simplify :if)
|
||
;; (simplify '(:if (:const . 2) (:const . nil) (:const . T)))
|
||
;; '(:const . nil))
|
||
|
||
;; (deftest (lisp2li simplify :if)
|
||
;; (simplify '(:if (:const . T) (:const . 3) (:const . 4)))
|
||
;; '(:const . 3))
|
||
|
||
;; (deftest (lisp2li simplify :if)
|
||
;; (simplify '(:if (:const 1 2 3) (:progn (:let 3 (:const . 3)) (:let 4 (:const . 4))) (:const . 4)))
|
||
;; '(:let 7 (:const . 3) (:const . 4)))
|
||
|
||
;; (deftest (lisp2li simplify :let-cvar)
|
||
;; (simplify '(:let 3 (:const . T) (:let 4 (:cvar 1 1) (:const . 4))))
|
||
;; '(:let 7 (:const . T) (:cvar 0 4) (:const . 4)))
|
||
|
||
;; (deftest (lisp2li simplify :let-cvar)
|
||
;; (simplify '(:progn (:cvar 0 1)
|
||
;; (:LET 1 (:CONST . T)
|
||
;; (:LET 2 (:CVAR 0 1) (:cvar 1 1) (:cvar 2 1) (:CONST . 4)))))
|
||
;; '(:let 3 (:cvar 0 1) (:const . T) (:cvar 0 1) (:cvar 0 2) (:cvar 1 2) (:const . 4)))
|
||
|
||
|
||
(deftest (lisp2li constante)
|
||
(lisp2li '3 ())
|
||
'(:const . 3))
|
||
|
||
(deftest (lisp2li constante)
|
||
(lisp2li ''x ())
|
||
'(:const . x))
|
||
|
||
(deftest (lisp2li constante)
|
||
(lisp2li ''(1 2 3) ())
|
||
'(:const 1 2 3))
|
||
|
||
(deftest (lisp2li variables)
|
||
(lisp2li 'x '((x 0 1) (y 0 2)))
|
||
'(:cvar 0 1))
|
||
|
||
(deftest (lisp2li fonctions-normales)
|
||
(lisp2li '(+ 3 4) ())
|
||
'(:call + (:const . 3) (:const . 4)))
|
||
|
||
(deftest (lisp2li fonctions-normales)
|
||
(lisp2li '(list 3 4 (* 6 7)) ())
|
||
'(:call list (:const . 3) (:const . 4)
|
||
(:call * (:const . 6) (:const . 7))))
|
||
|
||
(deftest (lisp2li if)
|
||
(lisp2li '(if T T nil) ())
|
||
'(:if (:const . T) (:const . T) (:const . nil)))
|
||
|
||
(deftest (lisp2li defun)
|
||
(lisp2li '(defun bar (x) x) ())
|
||
'(:mcall set-defun (:const . bar) (:lclosure 1 :cvar 0 1)))
|
||
|
||
(deftest (lisp2li defun)
|
||
(lisp2li '(defun foo (x y z) (list x y z)) ())
|
||
'(:mcall set-defun (:const . foo)
|
||
(:lclosure 3 :call list
|
||
(:cvar 0 1)
|
||
(:cvar 0 2)
|
||
(:cvar 0 3))))
|
||
|
||
(deftest (lisp2li setf)
|
||
(lisp2li '(setf y 42) '((x 0 1) (y 0 2)))
|
||
'(:set-var (0 2) (:const . 42)))
|
||
|
||
(deftest (lisp2li setf)
|
||
(lisp2li '(setf (cdr '(1 2 3)) 42) ())
|
||
'(:set-fun cdr 42 '(1 2 3)))
|
||
|
||
(deftest (lisp2li lambda)
|
||
(lisp2li '(mapcar (lambda (x y z) (list x y z)) '(1 2 3)) ())
|
||
'(:call mapcar (:lclosure 3 :call list
|
||
(:cvar 0 1)
|
||
(:cvar 0 2)
|
||
(:cvar 0 3))
|
||
(:const 1 2 3)))
|
||
|
||
(deftest (lisp2li lambda)
|
||
(lisp2li '((lambda (x y z) (list x y z)) 1 2 3) ())
|
||
'(:mcall (:lclosure 3 :call list
|
||
(:cvar 0 1)
|
||
(:cvar 0 2)
|
||
(:cvar 0 3))
|
||
(:const . 1) (:const . 2) (:const . 3)))
|
||
|
||
(deftest (lisp2li lambda)
|
||
(lisp2li `(lambda (x y z) (list x y z)) ())
|
||
'(:lclosure 3 :call list
|
||
(:cvar 0 1)
|
||
(:cvar 0 2)
|
||
(:cvar 0 3)))
|
||
|
||
(deftest (lisp2li lambda)
|
||
(lisp2li `(lambda (x y z) (list x y z) (+ x y)) ())
|
||
'(:lclosure 3 :progn (:call list
|
||
(:cvar 0 1)
|
||
(:cvar 0 2)
|
||
(:cvar 0 3))
|
||
(:call +
|
||
(:cvar 0 1)
|
||
(:cvar 0 2))))
|
||
|
||
(deftest (lisp2li rest)
|
||
(lisp2li `(lambda (x &rest y) (cons x y)) ())
|
||
'(:lclosure 2 2 :call cons
|
||
(:cvar 0 1)
|
||
(:cvar 0 2)))
|
||
|
||
(deftest (lisp2li unknown)
|
||
(lisp2li '(bar 3) ())
|
||
'(:unknown (bar 3) ()))
|
||
|
||
(deftest (lisp2li function)
|
||
(lisp2li '#'car ())
|
||
'(:sclosure car))
|
||
|
||
(deftest (lisp2li apply)
|
||
(lisp2li '(apply 'list '(1 2 3)) ())
|
||
'(:sapply 'list '(1 2 3)))
|
||
|
||
(deftest (lisp2li apply)
|
||
(lisp2li '(apply #'list '(1 2 3)) ())
|
||
'(:sapply #'list '(1 2 3)))
|
||
|
||
(deftest (lisp2li progn)
|
||
(lisp2li '(progn (list 1 2 3) (+ 3 4)) ())
|
||
'(:progn (:call list
|
||
(:const . 1)
|
||
(:const . 2)
|
||
(:const . 3))
|
||
(:call +
|
||
(:const . 3)
|
||
(:const . 4))))
|
||
|
||
;; TODO : on ne peut pas faire de tests sur des macros qu'on n'a pas implémentées nous-mêmes,
|
||
;; car sinon le résultat dépend de l'implémentation.
|
||
|
||
;; (deftest (lisp2li macro)
|
||
;; (lisp2li '(cond ((eq (car '(1 2 3)) 1) T)
|
||
;; ((eq (car '(1 2 3)) 2) 2)
|
||
;; (T nil))
|
||
;; ())
|
||
;; '(:if (:call eq (:call car (:const 1 2 3)) (:const . 1))
|
||
;; (:const . T)
|
||
;; (:if (:call eq (:call car (:const 1 2 3)) (:const . 2))
|
||
;; (:const . 2)
|
||
;; (:const . nil))))
|
||
|
||
;; (deftest (lisp2li macro)
|
||
;; (lisp2li '(and (eq (car '(1 2)) 1)
|
||
;; T)
|
||
;; ())
|
||
;; '(:if (:call not
|
||
;; (:call eq (:call car (:const 1 2)) (:const . 1)))
|
||
;; (:const . nil)
|
||
;; (:const . T)))
|
||
|
||
(deftest (lisp2li let)
|
||
(lisp2li '(let ((x 1) (y 2))
|
||
(cons x y)) ())
|
||
'(:let 2 (:set-var (0 1) (:const . 1))
|
||
(:set-var (0 2) (:const . 2))
|
||
(:call cons (:cvar 0 1) (:cvar 0 2))))
|
||
|
||
(deftest (lisp2li let)
|
||
(lisp2li '(let ((x 1) (y 2))
|
||
(cons x y)
|
||
(list x y)) ())
|
||
'(:let 2 (:set-var (0 1) (:const . 1))
|
||
(:set-var (0 2) (:const . 2))
|
||
(:progn
|
||
(:call cons (:cvar 0 1) (:cvar 0 2))
|
||
(:call list (:cvar 0 1) (:cvar 0 2)))))
|
||
|
||
(deftest (lisp2li let)
|
||
(lisp2li '(let ((x z) (y 2))
|
||
(cons x y)) '((z 0 1)))
|
||
'(:let 2 (:set-var (0 1) (:cvar 1 1))
|
||
(:set-var (0 2) (:const . 2))
|
||
(:call cons (:cvar 0 1) (:cvar 0 2))))
|
||
|
||
(deftest (lisp2li let)
|
||
(lisp2li '(let ((x 2))
|
||
(cons x z)) '((z 0 1)))
|
||
'(:let 1 (:set-var (0 1) (:const . 2))
|
||
(:call cons (:cvar 0 1) (:cvar 1 1))))
|
||
|
||
(provide 'lisp2li) |