;;; Gash -- Guile As SHell ;;; Copyright © 2018, 2019 Timothy Sample ;;; Copyright © 2018, 2019 Jan (janneke) Nieuwenhuizen ;;; ;;; This file is part of Gash. ;;; ;;; Gash is free software: you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation, either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; Gash is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with Gash. If not, see . (define-module (gash eval) #:use-module (gash arithmetic) #:use-module (gash compat) #:use-module (gash environment) #:use-module (gash pattern) #:use-module (gash shell) #:use-module (gash word) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:export (eval-word eval-sh)) ;;; Commentary: ;;; ;;; This module provides an interpreter for the Shell language. ;;; ;;; Code: (define eval-cmd-sub (make-parameter (lambda (exps) (throw 'eval-cmd-sub-unset)))) (define (string-not-null? str) "Check if @var{str} is a non-null string." (and (string? str) (not (string-null? str)))) (define (word->qword word) "Convert @var{word} into a qword by resolving all parameter, command, and arithmetic substitions." (match word ((? string?) word) ((' quoted-word) `( ,(word->qword quoted-word))) ((' . exps) ((eval-cmd-sub) exps)) ((' word) (let* ((arithmetic (expand-word word #:output 'string)) (expr `(begin (use-modules (gash environment)) (number->string ,(read-arithmetic arithmetic))))) (eval expr (interaction-environment)))) ((' name) (parameter-ref name "")) ((' name default) (or (parameter-ref name) (word->qword (or default "")))) ((' name default) (let ((value (parameter-ref name))) (if (string-not-null? value) value (word->qword (or default ""))))) ((' name default) (or (parameter-ref name) (let ((new-value (expand-word (or default "") #:output 'string #:rhs-tildes? #t))) (setvar! name new-value) new-value))) ((' name default) (let ((value (parameter-ref name))) (if (string-not-null? value) value (let ((new-value (expand-word (or default "") #:output 'string #:rhs-tildes? #t))) (setvar! name new-value) new-value)))) ((' name message) (or (parameter-ref name) (let ((message* (expand-word message #:output 'string))) (throw 'shell-error (format #f "~a: ~a" name message*))))) ((' name message) (let ((value (parameter-ref name))) (if (string-not-null? value) value (let ((message* (expand-word message #:output 'string))) (throw 'shell-error (format #f "~a: ~a" name message*)))))) ((' name value) (or (and (parameter-ref name) (word->qword (or value ""))) "")) ((' name value) (if (string-not-null? (parameter-ref name)) (word->qword (or value "")) "")) ((' name pattern-word) (let ((pattern (expand-word pattern-word #:output 'pattern))) (pattern-drop-right pattern (parameter-ref name "")))) ((' name pattern-word) (let ((pattern (expand-word pattern-word #:output 'pattern))) (pattern-drop-right pattern (parameter-ref name "") #:greedy? #t))) ((' name pattern-word) (let ((pattern (expand-word pattern-word #:output 'pattern))) (pattern-drop pattern (parameter-ref name "")))) ((' name pattern-word) (let ((pattern (expand-word pattern-word #:output 'pattern))) (pattern-drop pattern (parameter-ref name "") #:greedy? #t))) ((' name) (number->string (string-length (parameter-ref name "")))) (_ (map word->qword word)))) (define* (expand-word word #:key (output 'fields) (rhs-tildes? #f)) "Expand @var{word} into a list of fields." (let ((qword (word->qword word))) (expand-qword qword #:output output #:rhs-tildes? rhs-tildes?))) (define* (eval-word word #:key (output 'fields) (rhs-tildes? #f) (on-command-substitution noop)) (parameterize ((eval-cmd-sub (lambda (exps) (on-command-substitution) (sh:substitute-command (lambda () (for-each eval-sh exps)))))) (expand-word word #:output output #:rhs-tildes? rhs-tildes?))) (define (eval-redir redir) "Evaluate the redirect @var{redir}." (match-let* (((op fd word) redir) (field (eval-word word #:output 'string))) (match op ((or '>& '<&) (let ((n (string->number field))) (cond ((and n (exact-integer? n)) `(,op ,fd ,n)) ((string=? field "-") `(,op ,fd -)) (else (throw 'bad-dup))))) (_ `(,op ,fd ,field))))) (define (exp->thunk exp) ;; XXX: See comment in `exps->thunk'. (if exp (lambda () (eval-sh exp)) (lambda () (set-status! 0)))) (define (exps->thunk exps) ;; XXX: It probably makes more sense to exclude '#f' expressions at ;; the syntax level. For now, we filter them out here. (if exps (match (filter values exps) (() noop) (exps (lambda () (eval-sh `( ,@exps))))) (lambda () (set-status! 0)))) (define (eval-sh exp) "Evaluate the Shell expression @var{exp}." (match exp ((' exp1 exp2) (sh:and (exp->thunk exp1) (exp->thunk exp2))) ((' sub-exp) (sh:async (exp->thunk sub-exp))) ((' . sub-exps) (for-each eval-sh sub-exps)) ((' word (pattern-lists . sub-exp-lists) ...) (let ((value (eval-word word #:output 'string))) (apply sh:case value (map (lambda (patterns sub-exps) `(,(map (cut eval-word <> #:output 'pattern) patterns) ,(exps->thunk sub-exps))) pattern-lists sub-exp-lists)))) ((' (test-exps . sub-exp-lists) ..1) (apply sh:cond (map (lambda (test-exp sub-exps) `(,(match test-exp (' #t) (exp (exp->thunk exp))) ,(exps->thunk sub-exps))) test-exps sub-exp-lists))) ((' name . sub-exps) (let ((proc (lambda args (eval-sh `( ,@sub-exps))))) (defun! name proc))) ((' words ..1) (let ((args (append-map eval-word words))) (match args ((name . args) (apply sh:exec name args)) (() #f)))) ((' ((names var-words) ..1) cmd-words ..1) (let* ((args (append-map eval-word cmd-words)) (bindings (map (lambda (name word) `(,name . ,(eval-word word #:output 'string #:rhs-tildes? #t))) names var-words))) (match args ((name . args) (apply sh:exec-let bindings name args)) (() (for-each (match-lambda ((name . value) (setvar! name value))) bindings))))) ((' (name (words ...)) . sub-exps) (sh:for `(,name ,(append-map eval-word words)) (exps->thunk sub-exps))) ((' exp) (sh:not (exp->thunk exp))) ((' exp1 exp2) (sh:or (exp->thunk exp1) (exp->thunk exp2))) ((' cmd*s ..1) (apply sh:pipeline (map exp->thunk cmd*s))) ((' (names words) ..1) (let* ((command-substitution? #f) (thunk (lambda () (set! command-substitution? #t)))) (for-each (lambda (name word) (setvar! name (eval-word word #:output 'string #:rhs-tildes? #t #:on-command-substitution thunk))) names words) (unless command-substitution? (set-status! 0)))) ((' . sub-exps) (sh:subshell (exps->thunk sub-exps))) ((' test-exp sub-exps ..1) (sh:while (exp->thunk test-exp) (exps->thunk sub-exps))) ((' (redirs ..1) sub-exp) (match sub-exp ;; For "simple commands" we have to observe a special order of ;; evaluation: first command words, then redirects, and finally ;; assignment words. ((' words ..1) (let ((args (append-map eval-word words))) (match (false-if-exception (map eval-redir redirs)) (#f (set-status! 1)) (redirs (match args ;; This built-in, called with no arguments, is a very ;; special case. We need to treat the redirects ;; directly rather than pass them to ;; 'sh:with-redirects'. (("exec") (sh:set-redirects redirs)) ((name . args) (sh:with-redirects redirs (lambda () (apply sh:exec name args)))) (() #f)))))) ((' ((names var-words) ..1) cmd-words ..1) (let ((args (append-map eval-word cmd-words))) (match (false-if-exception (map eval-redir redirs)) (#f (set-status! 1)) (redirs (let ((bindings (map (lambda (name word) `(,name . ,(eval-word word #:output 'string #:rhs-tildes? #t))) names var-words))) (match args ;; See the '' case for why this built-in is ;; treated specially. (("exec") (sh:set-redirects redirs)) ((name . args) (sh:with-redirects redirs (lambda () (apply sh:exec-let bindings name args)))) (() (for-each (match-lambda ((name . value) (setvar! name value))) bindings)))))))) (_ (match (false-if-exception (map eval-redir redirs)) (#f (set-status! 1)) (redirs (sh:with-redirects redirs (exp->thunk sub-exp))))))) ((' test-exp sub-exps ..1) (sh:until (exp->thunk test-exp) (exps->thunk sub-exps)))))