221 lines
8.1 KiB
Scheme
221 lines
8.1 KiB
Scheme
(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))
|