From: David Vazquez <davazp@gmail.com>
Date: Sun, 16 Dec 2012 04:01:34 +0000 (+0000)
Subject: Define-transformation like light compiler macros
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=b27fcd30accc24a70887798f9d61e08c38d083dd;p=jscl.git

Define-transformation like light compiler macros

- Add progn
---

diff --git a/lispstrack.lisp b/lispstrack.lisp
index 176ca35..abc1b2b 100644
--- a/lispstrack.lisp
+++ b/lispstrack.lisp
@@ -159,6 +159,14 @@
       nil
       *eval-when-compilations*))
 
+
+(defmacro define-transformation (name args form)
+  `(define-compilation ,name ,args
+     (ls-compile ,form env fenv)))
+
+(define-transformation progn (&rest body)
+  `((lambda () ,@body)))
+
 ;;; aritmetic primitives
 (define-compilation + (x y)
   (concat "((" (ls-compile x env fenv) ") + (" (ls-compile y env fenv) "))"))
@@ -209,17 +217,25 @@
 (defun %compile-defmacro (name lambda)
   (push (cons name (cons 'macro lambda)) *fenv*))
 
-(defun compile-funcall (name args env fenv)
-  (format nil "~a(~{~a~^, ~})"
-          (lookup-function name fenv)
-          (mapcar (lambda (x) (ls-compile x env fenv)) args)))
-
 (defun ls-macroexpand-1 (form &optional env fenv)
   (let ((function (cdr (assoc (car form) *fenv*))))
     (if (and (listp function) (eq (car function) 'macro))
         (apply (eval (cdr function)) (cdr form))
         form)))
 
+(defun compile-funcall (function args env fenv)
+  (cond
+    ((symbolp function)
+     (format nil "~a(~{~a~^, ~})"
+             (lookup-function function fenv)
+             (mapcar (lambda (x) (ls-compile x env fenv)) args)))
+    ((and (listp function) (eq (car function) 'lambda))
+     (format nil "(~a)(~{~a~^, ~})"
+             (ls-compile function env fenv)
+             (mapcar (lambda (x) (ls-compile x env fenv)) args)))
+    (t
+     (error "Invalid function designator ~a." function))))
+
 (defun ls-compile (sexp &optional env fenv)
   (cond
     ((symbolp sexp) (lookup-variable sexp env))
diff --git a/test.lisp b/test.lisp
index a38014b..0f19c5f 100644
--- a/test.lisp
+++ b/test.lisp
@@ -19,6 +19,8 @@
 (fsetq f (lambda (x) (+ x 10)))
 (debug (f 20))
 
+(debug ((lambda (x) x) 9999))
+
 ;;; Macros
 (debug "---MACROS---")
 
@@ -53,6 +55,7 @@
 (debug (symbol-name 'foo))
 (debug (symbol-name 'foo-bar))
 
+(debug (progn 1 2 3 123))
 
 ;;; &rest lambda-list