248 lines
6.3 KiB
Plaintext
248 lines
6.3 KiB
Plaintext
(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 1 extras
|
||
|
||
(define (partition pred lst)
|
||
(let loop ((lst lst) (yeas '()) (nays '()))
|
||
(if (null? lst)
|
||
(values (reverse yeas) (reverse nays))
|
||
(let ((x (car lst)))
|
||
(if (pred x)
|
||
(loop (cdr lst) (cons x yeas) nays)
|
||
(loop (cdr lst) yeas (cons x nays)))))))
|
||
|
||
|
||
;; 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-concatenate-reverse lst)
|
||
(apply string-append (reverse lst)))
|
||
|
||
(define (char-pred pred)
|
||
(cond
|
||
((char? pred) (lambda (x) (char=? x pred)))
|
||
((char-set? pred) (lambda (x) (char-set-contains? pred x)))
|
||
((procedure? pred) pred)
|
||
(else (error "Invalid character predicate."))))
|
||
|
||
(define (string-every pred str)
|
||
(every (char-pred pred) (string->list str)))
|
||
|
||
(define (string-any pred str)
|
||
(any (char-pred pred) (string->list str)))
|
||
|
||
|
||
;; Vector functions
|
||
|
||
(define vector-empty?
|
||
(compose zero? vector-length))
|
||
|
||
(define (vector-every pred . lst)
|
||
(apply every pred (map vector->list lst)))
|
||
|
||
|
||
;; Prompts
|
||
|
||
(define* (make-prompt-tag #:optional (stem "prompt"))
|
||
(list stem))
|
||
|
||
|
||
;; Misc. fixes
|
||
|
||
(define-syntax-rule (define-inlinable stuff ...)
|
||
(define stuff ...))
|
||
|
||
(define the-eof-object (integer->char -1))
|
||
|
||
(define (noop . args) #f)
|
||
|
||
(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)))
|
||
|
||
|
||
;; Main show
|
||
|
||
(include-from-path "gash/lexer.scm")
|
||
(include-from-path "gash/parser.scm")
|
||
(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")
|
||
|
||
;; Arithmetic is hard without modules. Many names conflict with the
|
||
;; shell parser.
|
||
;; (include-from-path "gash/arithmetic.scm")
|
||
|
||
(include-from-path "gash/word.scm")
|
||
(include-from-path "gash/eval.scm")
|
||
|
||
;; XXX: Mes module loading seems to bork reading from stdin.
|
||
(set-current-input-port
|
||
(open-input-file "/home/samplet/code/gash/mes/test.sh"))
|
||
|
||
;; (sh:exec "guile" "--version")
|
||
|
||
(let ((script (read-sh-all)))
|
||
(write script)
|
||
(newline)
|
||
(display "******************************************\n")
|
||
(eval-sh `(<sh-begin> ,@script)))
|