From 2a52d37a15bef58eebf240916d007dd431c502f7 Mon Sep 17 00:00:00 2001 From: Timothy Sample Date: Mon, 19 Apr 2021 14:58:13 -0400 Subject: [PATCH] wip! Add a compiler. --- Makefile.am | 1 + gash/compile-tree-il.scm | 220 +++++++++++++++++++++++++++++++++++++++ language/sh/spec.scm | 2 + 3 files changed, 223 insertions(+) create mode 100644 gash/compile-tree-il.scm 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)) + + ((' quoted-word) + `(primcall list (const ) + ,(word->qword-tree-il quoted-word))) + + ((' . exps) + `(call (@ (gash shell) sh:substitute-command) + ,(make-thunk `(seq (call ,(cmd-sub-tree-il)) + ,(sh->tree-il* exps))))) + + ((' word) + (error "Cannot compile arithmetic substitutions.")) + + ((' name) + `(call (@ (gash word) parameter-ref) (const ,name) (const ""))) + + ((' 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 "")))))) + + ((' 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)))) + + ((' 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))))))) + + ((' name default) + (error "Not compilable")) + ((' name message) + (error "Not compilable")) + ((' name message) + (error "Not compilable")) + ((' name value) + (error "Not compilable")) + ((' name value) + (error "Not compilable")) + ((' name pattern-word) + (error "Not compilable")) + ((' name pattern-word) + (error "Not compilable")) + ((' name pattern-word) + (error "Not compilable")) + ((' name pattern-word) + (error "Not compilable")) + ((' 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 `( ,@exps))))) + (make-thunk '(call (@ (gash environment) set-status!) (const 0))))) + +(define (sh->tree-il exp) + (match exp + ((' exp1 exp2) + `(call (@ (gash shell) sh:and) ,(exp->thunk exp1) ,(exp->thunk exp2))) + + ((' sub-exp) + `(call (@ (gash shell) sh:async) ,(exp->thunk sub-exp))) + + ((' . sub-exps) + (fold-right (lambda (exp acc) + `(seq ,(sh->tree-il exp) ,acc)) + '(void) sub-exps)) + + ((' 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))) + + ((' (test-exps . sub-exp-lists) ..1) + `(call (@ (gash shell) sh:cond) + ,@(map (lambda (test-exp sub-exps) + `(primcall list + ,(match test-exp + (' '(const #t)) + (exp (exp->thunk exp))) + ,(exps->thunk sub-exps))) + test-exps + sub-exp-lists))) + + ((' name . sub-exps) + `(call (@ (gash environment) defun!) + (const ,name) + (lambda () + (lambda-case + ((() #f args #f () (,(gensym "args"))) + ,(sh->tree-il `( ,@sub-exps))))))) + + ((' 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)))))) + + ;; + + ((' (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)))) + + ((' exp) + `(call (@ (gash shell) sh:not) ,(exp->thunk exp))) + + ((' exp1 exp2) + `(call (@ (gash shell) sh:or) ,(exp->thunk exp1) ,(exp->thunk exp2))) + + ((' cmd*s ..1) + `(call (@ (gash shell) sh:pipeline) + ,@(map exp->thunk cmd*s))) + + ((' (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))))) + + ((' . 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 . (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)