2021-06-23 19:14:17 +01:00
|
|
|
|
(mes-use-module (mes fluids))
|
|
|
|
|
(mes-use-module (mes lalr))
|
|
|
|
|
(mes-use-module (mes match))
|
|
|
|
|
(mes-use-module (mes scm))
|
|
|
|
|
(mes-use-module (srfi srfi-1))
|
|
|
|
|
(mes-use-module (srfi srfi-8))
|
|
|
|
|
(mes-use-module (srfi srfi-9))
|
|
|
|
|
(mes-use-module (srfi srfi-14))
|
|
|
|
|
(mes-use-module (srfi srfi-26))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;; SRFI 14 extras
|
|
|
|
|
|
|
|
|
|
(define (char-set-union . css)
|
|
|
|
|
(apply lset-union equal? css))
|
|
|
|
|
|
|
|
|
|
(define (char-set-intersection . css)
|
|
|
|
|
(apply lset-intersection equal? css))
|
|
|
|
|
|
|
|
|
|
(define char-set:ascii
|
|
|
|
|
(list->char-set (map integer->char (iota 128))))
|
|
|
|
|
|
|
|
|
|
(define char-set:letter
|
|
|
|
|
(char-set-union char-set:upper-case char-set:lower-case))
|
|
|
|
|
|
|
|
|
|
(define char-set:letter+digit
|
|
|
|
|
(char-set-union char-set:letter char-set:digit))
|
|
|
|
|
|
|
|
|
|
(define char-set:blank
|
|
|
|
|
(char-set #\tab #\space))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;; Parameters
|
|
|
|
|
|
|
|
|
|
;; This is cute, but maybe a record would be better.
|
|
|
|
|
(define *fluid-accessor* (list 'fluid-accessor))
|
|
|
|
|
|
|
|
|
|
(define (make-parameter init)
|
|
|
|
|
(define fluid (make-fluid init))
|
|
|
|
|
(lambda args
|
|
|
|
|
(if (null? args)
|
|
|
|
|
(fluid-ref fluid)
|
|
|
|
|
(let ((new-value (car args)))
|
|
|
|
|
(if (eq? new-value *fluid-accessor*)
|
|
|
|
|
fluid
|
|
|
|
|
(let ((old-value (fluid-ref fluid)))
|
|
|
|
|
(fluid-set! new-value)
|
|
|
|
|
old-value))))))
|
|
|
|
|
|
|
|
|
|
(define-syntax-rule (parameterize ((param value) ...) body ...)
|
|
|
|
|
(with-fluids (((param *fluid-accessor*) value) ...) body ...))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;; Input shims
|
|
|
|
|
|
|
|
|
|
(define-record-type <soft-input-port>
|
|
|
|
|
(make-soft-input-port thunk buffer)
|
|
|
|
|
soft-input-port?
|
|
|
|
|
(thunk soft-input-port-thunk)
|
|
|
|
|
(buffer soft-input-port-buffer set-soft-input-port-buffer!))
|
|
|
|
|
|
|
|
|
|
(define (make-soft-port pv modes)
|
|
|
|
|
(unless (equal? modes "r")
|
|
|
|
|
(error "Soft ports must have mode \"r\""))
|
|
|
|
|
(make-soft-input-port (vector-ref pv 3) '()))
|
|
|
|
|
|
|
|
|
|
(define (push-soft-input-port-buffer! sip char)
|
|
|
|
|
(let ((buffer (soft-input-port-buffer sip)))
|
|
|
|
|
(set-soft-input-port-buffer! sip (cons char buffer))))
|
|
|
|
|
|
|
|
|
|
(define (pop-soft-input-port-buffer! sip)
|
|
|
|
|
(let* ((buffer (soft-input-port-buffer sip))
|
|
|
|
|
(result (car buffer)))
|
|
|
|
|
(set-soft-input-port-buffer! sip (cdr buffer))
|
|
|
|
|
result))
|
|
|
|
|
|
|
|
|
|
(define-syntax-rule (with-input-port port body ...)
|
|
|
|
|
(let ((old-port (current-input-port)))
|
|
|
|
|
(set-current-input-port port)
|
|
|
|
|
(let ((result (begin body ...)))
|
|
|
|
|
(set-current-input-port old-port)
|
|
|
|
|
result)))
|
|
|
|
|
|
|
|
|
|
(define (get-char port)
|
|
|
|
|
(if (soft-input-port? port)
|
|
|
|
|
(let ((thunk (soft-input-port-thunk port))
|
|
|
|
|
(buffer (soft-input-port-buffer port)))
|
|
|
|
|
(if (null? buffer)
|
|
|
|
|
(thunk)
|
|
|
|
|
(pop-soft-input-port-buffer! port)))
|
|
|
|
|
(with-input-port port (read-char))))
|
|
|
|
|
|
|
|
|
|
(define (unget-char port char)
|
|
|
|
|
(if (soft-input-port? port)
|
|
|
|
|
(push-soft-input-port-buffer! port char)
|
|
|
|
|
(with-input-port port (unread-char char))))
|
|
|
|
|
|
|
|
|
|
(define (lookahead-char port)
|
|
|
|
|
(let ((result (get-char port)))
|
|
|
|
|
(unget-char port result)
|
|
|
|
|
result))
|
|
|
|
|
|
|
|
|
|
(define (set-port-line! port line)
|
|
|
|
|
#f)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;; String funtions
|
|
|
|
|
|
|
|
|
|
(define (string-every pred str)
|
|
|
|
|
(every pred (string->list str)))
|
|
|
|
|
|
2021-06-25 18:48:58 +01:00
|
|
|
|
|
|
|
|
|
;; Prompts
|
|
|
|
|
|
|
|
|
|
(define* (make-prompt-tag #:optional (stem "prompt"))
|
|
|
|
|
(list stem))
|
|
|
|
|
|
2021-06-23 19:14:17 +01:00
|
|
|
|
|
|
|
|
|
;; Misc. fixes
|
|
|
|
|
|
|
|
|
|
(define-syntax-rule (define-inlinable stuff ...)
|
|
|
|
|
(define stuff ...))
|
|
|
|
|
|
|
|
|
|
(define the-eof-object (integer->char -1))
|
|
|
|
|
|
|
|
|
|
(define (noop . args) #f)
|
|
|
|
|
|
2021-06-25 18:48:58 +01:00
|
|
|
|
(define (alist->hash-table alist)
|
|
|
|
|
(define ht (make-hash-table 100))
|
|
|
|
|
(fold-right (lambda (kvp acc)
|
|
|
|
|
(hash-set! ht (car kvp) (cdr kvp)))
|
|
|
|
|
#f
|
|
|
|
|
alist)
|
|
|
|
|
ht)
|
|
|
|
|
|
|
|
|
|
;; FIXME: Actually do somrething here.
|
|
|
|
|
(define (canonicalize-path path) path)
|
|
|
|
|
|
|
|
|
|
;; Shadow these so that optional arguments work.
|
|
|
|
|
(define mes-make-hash-table make-hash-table)
|
|
|
|
|
(define mes-hash-ref hash-ref)
|
|
|
|
|
(define* (make-hash-table #:optional (size 0))
|
|
|
|
|
(mes-make-hash-table size))
|
|
|
|
|
(define* (hash-ref table key #:optional dflt)
|
|
|
|
|
(mes-hash-ref table key dflt))
|
|
|
|
|
|
|
|
|
|
(define X_OK 1)
|
|
|
|
|
|
|
|
|
|
(define program-arguments command-line)
|
|
|
|
|
|
|
|
|
|
(define (hash-fold proc init table)
|
|
|
|
|
(define (proc* kvp acc)
|
|
|
|
|
(proc (car kvp) (cdr kvp) acc))
|
|
|
|
|
(define buckets (struct-ref table 4))
|
|
|
|
|
(let loop ((k 0) (acc init))
|
|
|
|
|
(if (>= k (vector-length buckets))
|
|
|
|
|
acc
|
|
|
|
|
(let ((bucket (vector-ref buckets k)))
|
|
|
|
|
(loop (1+ k)
|
|
|
|
|
(if (pair? bucket)
|
|
|
|
|
(fold proc* acc bucket)
|
|
|
|
|
acc))))))
|
|
|
|
|
|
|
|
|
|
(define delete-duplicates! delete-duplicates)
|
|
|
|
|
|
|
|
|
|
;; Mes does not have port buffers.
|
|
|
|
|
(define flush-all-ports noop)
|
|
|
|
|
|
|
|
|
|
;; Mes uses raw file descriptors for file ports.
|
|
|
|
|
(define file-port? number?)
|
|
|
|
|
|
|
|
|
|
;; This is probably OK....
|
|
|
|
|
(define (input-port? port) #f)
|
|
|
|
|
(define (output-port? port) #f)
|
|
|
|
|
|
|
|
|
|
;; More interface adjustments.
|
|
|
|
|
(define mes-dup dup)
|
|
|
|
|
(define* (dup fd #:optional new)
|
|
|
|
|
(if new (dup2 fd new) (dup fd)))
|
|
|
|
|
|
2021-06-23 19:14:17 +01:00
|
|
|
|
|
|
|
|
|
;; Main show
|
|
|
|
|
|
|
|
|
|
(include-from-path "gash/lexer.scm")
|
|
|
|
|
(include-from-path "gash/parser.scm")
|
2021-06-25 18:48:58 +01:00
|
|
|
|
(include-from-path "gash/environment.scm")
|
|
|
|
|
(include-from-path "gash/pattern.scm")
|
|
|
|
|
|
|
|
|
|
;; These should come from (gash built-ins), but that whole system needs
|
|
|
|
|
;; to be reworked.
|
|
|
|
|
(define (search-built-ins name) #f)
|
|
|
|
|
(define (search-special-built-ins name) #f)
|
|
|
|
|
|
|
|
|
|
(include-from-path "gash/shell.scm")
|
2021-06-23 19:14:17 +01:00
|
|
|
|
|
|
|
|
|
;; XXX: Mes module loading seems to bork reading from stdin.
|
|
|
|
|
(set-current-input-port
|
|
|
|
|
(open-input-file "/home/samplet/code/gash/mes/test.sh"))
|
|
|
|
|
|
2021-06-25 18:48:58 +01:00
|
|
|
|
(sh:exec "guile" "--version")
|
|
|
|
|
|
2021-06-23 19:14:17 +01:00
|
|
|
|
(write (read-sh-all))
|
|
|
|
|
(newline)
|