andrius
/
gash
mirror of https://git.savannah.gnu.org/git/gash.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

wip! Add a compiler.

This commit is contained in:
Timothy Sample 2021-04-19 14:58:13 -04:00
parent 87229e4b3a
commit 2a52d37a15
3 changed files with 223 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
Makefile.am
View File

@ -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 \

220
gash/compile-tree-il.scm Normal file
View File

@ -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))

2
language/sh/spec.scm
View File

@ -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)