wip! Add a compiler.wip-compiler

3 files changed, 223 insertions, 0 deletions

diff --git a/Makefile.am b/Makefile.am
index c4deefa..0e51c1f 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -66,6 +66,7 @@ SOURCES =                                       \
   gash/compat/srfi-43.scm                       \
   gash/compat/textual-ports.scm                 \
   gash/compat.scm                               \
+  gash/compile-tree-il.scm                      \
   gash/config.scm                               \
   gash/environment.scm                          \
   gash/eval.scm                                 \
diff --git a/gash/compile-tree-il.scm b/gash/compile-tree-il.scm
new file mode 100644
index 0000000..26c8ad8
--- /dev/null
+++ b/gash/compile-tree-il.scm
@@ -0,0 +1,220 @@
+(define-module (gash compile-tree-il)
+  #:use-module (language tree-il)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:export (compile-tree-il))
+
+(define cmd-sub-tree-il
+  (make-parameter '(@ (guile) noop)))
+
+(define (make-thunk tree-il)
+  `(lambda ()
+     (lambda-case
+      ((() #f #f #f () ()) ,tree-il))))
+
+(define (word->qword-tree-il word)
+  (match word
+    ((? string?)
+     `(const ,word))
+
+    (('<sh-quote> quoted-word)
+     `(primcall list (const <sh-quote>)
+                ,(word->qword-tree-il quoted-word)))
+
+    (('<sh-cmd-sub> . exps)
+     `(call (@ (gash shell) sh:substitute-command)
+            ,(make-thunk `(seq (call ,(cmd-sub-tree-il))
+                               ,(sh->tree-il* exps)))))
+
+    (('<sh-arithmetic> word)
+     (error "Cannot compile arithmetic substitutions."))
+
+    (('<sh-ref> name)
+     `(call (@ (gash word) parameter-ref) (const ,name) (const "")))
+
+    (('<sh-ref-or> name default)
+     (let ((value (gensym "value")))
+       `(let (value) (,value)
+             (call (@ (gash word) parmater-ref) (const name))
+             (if (lexical value ,value)
+                 (lexical value ,value)
+                 ,(word->qword-tree-il (or default ""))))))
+
+    (('<sh-ref-or*> name default)
+     (let ((value (gensym "value"))
+           (default-tree-il (word->qword-tree-il (or default ""))))
+       `(let (value) (,value)
+             (call (@ (gash word) parmater-ref) (const name))
+             (if (call (@ (guile) string?) (lexical value ,value))
+                 (if (call (@ (guile) not)
+                           (call (@ (guile) string-null?)
+                                 (lexical value ,value)))
+                     (lexical value ,value)
+                     ,default-tree-il)
+                 ,default-tree-il))))
+
+    (('<sh-ref-or!> name default)
+     (let ((value (gensym "value"))
+           (new-value (gensym "new-value")))
+       `(let (value) (,value)
+             (call (@ (gash word) parmater-ref) (const name))
+             (if (lexical value ,value)
+                 (lexical value ,value)
+                 (let (new-value) (,new-value)
+                      (call (@ (gash word) expand-qword)
+                            ,(word->qword-tree-il (or default ""))
+                            (const #:output) (const 'string)
+                            (const #:rhs-tildes?) (const #t))
+                      (seq (call (@ (gash environment) setvar!)
+                                 (const name)
+                                 (lexical new-value ,new-value))
+                           (lexical new-value ,new-value)))))))
+
+    (('<sh-ref-or!*> name default)
+     (error "Not compilable"))
+    (('<sh-ref-assert> name message)
+     (error "Not compilable"))
+    (('<sh-ref-assert*> name message)
+     (error "Not compilable"))
+    (('<sh-ref-and> name value)
+     (error "Not compilable"))
+    (('<sh-ref-and*> name value)
+     (error "Not compilable"))
+    (('<sh-ref-except-min> name pattern-word)
+     (error "Not compilable"))
+    (('<sh-ref-except-max> name pattern-word)
+     (error "Not compilable"))
+    (('<sh-ref-skip-min> name pattern-word)
+     (error "Not compilable"))
+    (('<sh-ref-skip-max> name pattern-word)
+     (error "Not compilable"))
+    (('<sh-ref-length> name)
+     (error "Not compilable"))
+    ;; XXX:
+    (_ (error "Not compilable"))))
+
+(define* (word->tree-il word #:key (output 'fields) rhs-tildes?
+                        on-command-substitution)
+  `(call (@ (gash word) expand-qword)
+         ,(word->qword-tree-il word)
+         (const #:output) (const ,output)
+         (const #:rhs-tildes?) (const ,rhs-tildes?)))
+
+(define (exp->thunk exp)
+  (if exp
+      (make-thunk (sh->tree-il exp))
+      (make-thunk '(call (@ (gash environment) set-status!) (const 0)))))
+
+(define (exps->thunk exps)
+  (if exps
+      (match (filter identity exps)
+        (() (make-thunk '(call (@ (gash environment) set-status!) (const 0))))
+        (exps (make-thunk (sh->tree-il `(<sh-begin> ,@exps)))))
+      (make-thunk '(call (@ (gash environment) set-status!) (const 0)))))
+
+(define (sh->tree-il exp)
+  (match exp
+    (('<sh-and> exp1 exp2)
+     `(call (@ (gash shell) sh:and) ,(exp->thunk exp1) ,(exp->thunk exp2)))
+
+    (('<sh-async> sub-exp)
+     `(call (@ (gash shell) sh:async) ,(exp->thunk sub-exp)))
+
+    (('<sh-begin> . sub-exps)
+     (fold-right (lambda (exp acc)
+                   `(seq ,(sh->tree-il exp) ,acc))
+                 '(void) sub-exps))
+
+    (('<sh-case> word (pattern-lists . sub-exp-lists) ...)
+     `(call (@ (gash shell) sh:case)
+            ,(word->tree-il word #:output 'string)
+            ,@(map (lambda (patterns sub-exps)
+                     (let ((word->pattern (cut word->tree-il <>
+                                               #:output 'pattern)))
+                       `(primcall list (primcall list ,@(map word->pattern
+                                                             patterns))
+                                  ,(exps->thunk sub-exps))))
+                   pattern-lists
+                   sub-exp-lists)))
+
+    (('<sh-cond> (test-exps . sub-exp-lists) ..1)
+     `(call (@ (gash shell) sh:cond)
+            ,@(map (lambda (test-exp sub-exps)
+                     `(primcall list
+                                ,(match test-exp
+                                   ('<sh-else> '(const #t))
+                                   (exp (exp->thunk exp)))
+                                ,(exps->thunk sub-exps)))
+                   test-exps
+                   sub-exp-lists)))
+
+    (('<sh-defun> name . sub-exps)
+     `(call (@ (gash environment) defun!)
+            (const ,name)
+            (lambda ()
+              (lambda-case
+               ((() #f args #f () (,(gensym "args")))
+                ,(sh->tree-il `(<sh-begin> ,@sub-exps)))))))
+
+    (('<sh-exec> words ..1)
+     (let ((words (map word->tree-il words))
+           (args (gensym "args")))
+       `(let (args) (,args) ((primcall append ,@words))
+             (if (primcall null? (lexical args ,args))
+                 (const #f)
+                 (primcall apply (@ (gash shell) sh:exec)
+                           (lexical args ,args))))))
+
+    ;; <sh-exec-let>
+
+    (('<sh-for> (name (words ...)) . sub-exps)
+     (let ((words (map word->tree-il words)))
+       `(call (@ (gash shell) sh:for)
+              (primcall list (const ,name) (primcall append ,@words))
+              ,(exps->thunk sub-exps))))
+
+    (('<sh-not> exp)
+     `(call (@ (gash shell) sh:not) ,(exp->thunk exp)))
+
+    (('<sh-or> exp1 exp2)
+     `(call (@ (gash shell) sh:or) ,(exp->thunk exp1) ,(exp->thunk exp2)))
+
+    (('<sh-pipeline> cmd*s ..1)
+     `(call (@ (gash shell) sh:pipeline)
+            ,@(map exp->thunk cmd*s)))
+
+    (('<sh-set!> (names words) ..1)
+     (let ((command-substitution? (gensym "command-substitution?")))
+       (parameterize ((cmd-sub-tree-il
+                       (make-thunk `(set! (lexical command-substitution?
+                                                   ,command-substitution?)
+                                      (const #t)))))
+         `(let (command-substitution?) (,command-substitution?) ((const #f))
+               ,(fold-right (lambda (name word acc)
+                              `(seq (call (@ (gash environment) setvar!)
+                                          (const ,name)
+                                          ,(word->tree-il word
+                                                          #:output 'string
+                                                          #:rhs-tildes? #t))
+                                    ,acc))
+                            `(if (lexical command-substitution?
+                                          ,command-substitution?)
+                                 (void)
+                                 (call (@ (gash environment) set-status!)
+                                       (const 0)))
+                            names words)))))
+
+    (('<sh-subshell> . sub-exps)
+     `(call ))))
+
+(define (sh->tree-il* exps)
+  (match exps
+    (() '(void))
+    ((exp) (sh->tree-il exp))
+    ((first-exp . rest-exps)
+     `(seq ,(sh->tree-il first-exp)
+           ,(sh->tree-il* rest-exps)))))
+
+(define (compile-tree-il exp env opts)
+  (values (parse-tree-il (sh->tree-il exp)) env env))
diff --git a/language/sh/spec.scm b/language/sh/spec.scm
index 894e368..2bba61d 100644
--- a/language/sh/spec.scm
+++ b/language/sh/spec.scm
@@ -17,6 +17,7 @@
 ;;; along with Gash.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (language sh spec)
+  #:use-module (gash compile-tree-il)
   #:use-module (gash environment)
   #:use-module (gash eval)
   #:use-module (gash parser)
@@ -35,4 +36,5 @@
   #:title "Guile as Shell"
   #:reader (lambda (port env) (read-sh port))
   #:evaluator (lambda (x module) (eval-sh x) (get-status))
+  #:compilers `((tree-il . ,compile-tree-il))
   #:printer write)