From 634cde85bfde8c8f500770615890992a6fe61d04 Mon Sep 17 00:00:00 2001
From: eknauel <eknauel>
Date: Sun, 7 Aug 2005 14:46:57 +0000
Subject: [PATCH] Add abstract syntax, lexer, parser, and unparser for the
 command language

---
 scheme/cmdline.scm       | 321 +++++++++++++++++++++++++++++++++++++++
 scheme/nuit-packages.scm |  61 ++++++++
 2 files changed, 382 insertions(+)
 create mode 100644 scheme/cmdline.scm

diff --git a/scheme/cmdline.scm b/scheme/cmdline.scm
new file mode 100644
index 0000000..b4d4159
--- /dev/null
+++ b/scheme/cmdline.scm
@@ -0,0 +1,321 @@
+;; ,open extended-ports define-record-types srfi-1 srfi-6 srfi-8 srfi-13 srfi-14 silly signals handle
+
+;; command line language:
+;;
+;; <cmdline> ::= (<cmd> (<sep> <cmd>)* <jobctrl>?
+;; <cmd>     ::= <prog> <arg>* <redir>*
+;; <redir>   ::= <redirop> <fname>
+;; <redirop> ::= ">" | ">>" | "<<" | "<"
+;; <fname>   ::= <string> | <unquote>
+;; <prog>    ::= <string> | <unquote>
+;; <string>  ::= "..." | char+  with char = ASCII\{"&","|","<",">",","}
+;; <jobctrl> ::= "&" | "&*"
+;; <sep>     ::= "|" | "&&" | "||" | ";"
+;; <unquote> ::= "," <s-expr> | ",@" <s-expr>
+
+;; lexer stuff
+
+(define-record-type token :token
+  (make-token token type pos)
+  token?
+  (token token-token)
+  (type token-type)
+  (pos token-pos))
+
+(define-record-discloser :token
+  (lambda (r)
+    `(token (,(token-type r) ,(token-pos r) ,(token-token r)))))
+
+(define (make-string-token data pos)
+  (make-token data 'string pos))
+
+(define (string-token? thing)
+  (and (token? thing) (eq? (token-type thing) 'string)))
+
+(define (make-s-expr-token data pos)
+  (make-token data 's-expr pos))
+
+(define (s-expr-token? thing)
+  (and (token? thing) (eq? (token-type thing) 's-expr)))
+
+(define (make-operator-token data pos)
+  (make-token data 'operator pos))
+
+(define (operator-token? thing)
+  (and (token? thing) (eq? (token-type thing) 'operator)))
+
+(define operator-chars (char-set #\& #\| #\< #\> #\, #\;))
+
+(define composed-operator-derivations 
+  (char-set #\& #\* #\| #\> #\<))
+
+(define (valid-operator? str)
+  (member str '("&" "&&" "&*" "|" "||" "<" "<<" ">" ">>" "," ",@" ";")))
+
+(define token-terminating-chars
+  (char-set-union operator-chars char-set:whitespace))
+
+(define (lex-token port)
+  (let ((start-pos (current-column port)))
+    (let lp ((c (peek-char port)) (chars '()))
+      (cond
+       ((or (eof-object? c)
+	    (char-set-contains? token-terminating-chars c))
+	(make-string-token 
+	 (reverse-list->string chars (length chars))
+	 start-pos))
+       (else
+	(read-char port)
+	(lp (peek-char port) (cons c chars)))))))
+
+(define (lex-operator port)
+  (let ((start-pos (current-column port)) ; makes no sense, do it anyways
+	(c-1 (read-char port))
+	(c-2 (peek-char port)))
+    (if (eof-object? c-2)
+	(make-operator-token (string->symbol (string c-1)) start-pos)
+	(let ((c (if (char-set-contains? composed-operator-derivations c-2)
+		     (begin
+		       (read-char port)
+		   (string-append (string c-1) (string c-2)))
+		     (string c-1))))
+	  (cond 
+	   ((valid-operator? c)
+	    (make-operator-token (string->symbol c) start-pos))
+	   (else
+	    (error "Invalid operator in command line" c start-pos)))))))
+
+(define (lex-port port)
+  (let lp ((c (peek-char port)) (tokens '()))
+    (cond
+     ((eof-object? c)
+      (reverse tokens))
+     ((or (char=? c #\") (char=? c #\,))
+      (let ((token (make-s-expr-token 
+		    (read port) (current-column port))))
+	(lp (peek-char port) (cons token tokens))))
+     ((char-set-contains? operator-chars c)
+      (let ((token (lex-operator port)))
+	(lp (peek-char port) (cons token tokens))))
+     ((char-set-contains? char-set:whitespace c)
+      (read-char port)
+      (lp (peek-char port) tokens))
+     (else
+      (let ((token (lex-token port)))
+	(lp (peek-char port) (cons token tokens)))))))
+
+(define (lex-command-line cmd-line)
+  (lex-port 
+   (make-tracking-input-port (make-string-input-port cmd-line))))
+
+;; abstract syntax
+
+(define-record-type command-line :command-line
+  (make-command-line first-cmd combinator/cmds job-ctrl)
+  command-line?
+  (first-cmd command-line-first-cmd)
+  (combinator/cmds command-line-combinator/cmds)
+  (job-ctrl command-line-job-ctrl))
+
+(define-record-discloser :command-line
+  (lambda (r)
+    `(command-line ,(command-line-first-cmd r)
+		   ,(command-line-combinator/cmds r)
+		   ,(command-line-job-ctrl r))))
+
+(define-record-type command :command
+  (make-command executable args redirections)
+  command?
+  (executable command-executable)
+  (args command-args)
+  (redirections command-redirections))
+
+(define-record-discloser :command
+  (lambda (r)
+    `(command ,(command-executable r)
+	      ,(command-args r) ,(command-redirections r))))
+
+(define-record-type redirection :redirection
+  (make-redirection op dest)
+  redirection?
+  (op redirection-op)
+  (dest redirection-dest))
+
+(define-record-discloser :redirection
+  (lambda (r)
+    `(redir ,(redirection-op r) ,(redirection-dest r))))
+
+;; a simple recursive descent parser
+(define (parse-error reason . more)
+  (error (string-append "error parsing command line; " reason) 
+	 more))
+
+(define (parse-error-unexpected-end where)
+  (parse-error "unexpected end of line" where))
+
+(define (string-or-s-expr? token)
+  (or (string-token? token) (s-expr-token? token)))
+
+(define (parse-string/s-expr tokens)
+  (if (null? tokens)
+      (parse-error-unexpected-end 'parse-string/s-expr)
+      (let ((t (car tokens)))
+	(if (or (string-token? t) (s-expr-token? t))
+	    (values (token-token t) (cdr tokens))
+	    (parse-error 
+	     "not a string or s-expr" 'parse-string/s-expr
+	     t tokens)))))
+
+(define (parse-many-satisfying predicate tokens)
+  (let lp ((tokens tokens) (found '()))
+    (if (or (null? tokens) (not (predicate (car tokens))))
+	(values (reverse found) tokens)
+	(lp (cdr tokens) (cons (car tokens) found)))))
+
+(define (parse-redirection tokens)
+  (if (< (length tokens) 2)
+      (values #f tokens)
+      (let ((op (car tokens))
+	    (obj (cadr tokens)))
+	(cond
+	 ((and (operator-token? op)
+	       (member (token-token op) '(> < >>))
+	       (string-or-s-expr? obj))
+	  (values 
+	   (make-redirection (token-token op) (token-token obj))
+	   (cddr tokens)))
+	 ((and (operator-token? op)
+	       (eq? (token-token op) '<<)
+	       (s-expr-token? obj))
+	  (values 
+	   (make-redirection (token-token op) (token-token obj))
+	   (cddr tokens)))
+	 (else
+	  (values #f tokens))))))
+
+(define (parse-redirections tokens)
+  (let lp ((tokens tokens) (redirs '()))
+    (receive (redir tokens)
+	(parse-redirection tokens)
+      (if redir
+	  (lp tokens (cons redir redirs))
+	    (values (reverse redirs) tokens)))))
+
+(define (parse-command tokens)
+  (receive (executable tokens)
+      (parse-string/s-expr tokens)
+    (receive (args tokens)
+	(parse-many-satisfying string-or-s-expr? tokens)
+      (receive (redirs tokens)
+	  (parse-redirections tokens)
+	(values (make-command executable 
+			      (map token-token args) redirs) 
+		tokens)))))
+
+(define combinator-tokens
+  (map string->symbol '(";" "|" "&&" "||")))
+
+(define (combinator-token? token)
+  (and (operator-token? token)
+       (member (token-token token) combinator-tokens)))
+
+(define (parse-combinator/command tokens)
+  (if (< (length tokens) 2)
+      (values #f tokens)
+      (let ((comb (car tokens))
+	    (cmd (cdr tokens)))
+	(cond
+	 ((combinator-token? comb)
+	  (receive (command tokens)
+	      (parse-command cmd)
+	    (values (cons (token-token comb) command)
+		    tokens)))
+	 (else
+	  (values #f tokens))))))
+
+(define (parse-combinators/commands-list tokens)
+  (let lp ((tokens tokens) (combs/cmds '()))
+    (receive (comb/cmd tokens)
+	(parse-combinator/command tokens)
+      (if comb/cmd
+	  (lp tokens (cons comb/cmd combs/cmds))
+	  (values (reverse combs/cmds) tokens)))))
+
+(define (parse-job-control tokens)
+  (if (null? tokens)
+      (values #f tokens)
+      (let ((t (car tokens)))
+	(if  (and (operator-token? t)
+		  (member (token-token t) '(&& &)))
+	     (values (token-token t) (cdr tokens))
+	     (values #f tokens)))))
+	
+(define (parse-command-line tokens)
+  (receive (command tokens)
+      (parse-command tokens)
+    (receive (combinator/command-list tokens)
+	(parse-combinators/commands-list tokens)
+      (receive (job-control tokens)
+	  (parse-job-control tokens)
+	(if (null? tokens)
+	    (make-command-line command combinator/command-list
+			       job-control)
+	    (error "error parsing command line" tokens))))))
+
+;; unparser
+
+(define append* 
+  (lambda args
+    (apply append
+	   (map (lambda (arg)
+		  (if (pair? arg)
+		      arg
+		      (list arg)))
+		(filter (lambda (v) (not (null? v)))
+			args)))))
+
+(define string-join*
+  (lambda args
+    (string-join (apply append* args))))
+
+(define (unparse-arbitrary v)
+  (let ((p (open-output-string)))
+    (display v p)
+    (get-output-string p)))
+
+(define (unparse-string/s-expr v)
+  (cond
+   ((string? v) v)
+   ((and (pair? v) (eq? (car v) 'unquote))
+    (string-append 
+     "," (unparse-arbitrary (cadr v))))
+   ((and (pair? v) (eq? (car v) 'unquote-splicing))
+    (string-append
+     ",@" (unparse-arbitrary (cadr v))))
+   (else
+    (unparse-arbitrary v))))
+
+(define (unparse-redirection rd)
+  (string-join*
+   (symbol->string (redirection-op rd))
+   (unparse-string/s-expr (redirection-dest rd))))
+
+(define (unparse-command cmd)
+  (string-join*
+   (unparse-string/s-expr (command-executable cmd))
+   (map unparse-string/s-expr (command-args cmd))
+   (map unparse-redirection 
+	(command-redirections cmd))))
+
+(define (unparse-command-line cmdln)
+  (string-join*
+   (unparse-command (command-line-first-cmd cmdln))
+   (map (lambda (comb.cmd)
+	  (string-append
+	   (symbol->string (car comb.cmd))
+	   " "
+	   (unparse-command (cdr comb.cmd))))
+	(command-line-combinator/cmds cmdln))
+   (cond ((command-line-job-ctrl cmdln)
+	  => symbol->string)
+	 (else '()))))
diff --git a/scheme/nuit-packages.scm b/scheme/nuit-packages.scm
index 79b33a1..6918702 100644
--- a/scheme/nuit-packages.scm
+++ b/scheme/nuit-packages.scm
@@ -558,6 +558,67 @@
 	console)
   (files job))
 
+;;; command line parser
+
+(define-interface command-line-lexer-tokens-interface
+  (export 
+   token? token-token token-type token-pos
+   string-token?
+   s-expr-token?
+   operator-token?))
+
+(define-interface command-line-lexer-interface
+  (export lex-command-line))
+
+(define-interface command-line-absyn-interface
+  (export
+   command-line?
+   command-line-first-cmd 
+   command-line-combinator/cmds
+   command-line-job-ctrl
+
+   command?
+   command-executable
+   command-args
+   command-redirections
+
+   redirection?
+   redirection-op
+   redirection-dest))
+
+(define-interface command-line-absyn-constructors-interface
+  (export
+   make-command-line
+   make-command
+   make-redirection))
+
+(define-interface command-line-parser-interface
+  (export parse-command-line
+	  unparse-command-line))
+
+(define-structures
+  ((command-line-lexer (compound-interface
+			command-line-lexer-tokens-interface
+			command-line-lexer-interface))
+   (command-line-parser (compound-interface
+			 command-line-absyn-interface
+			 command-line-parser-interface))
+   (command-line-absyn (compound-interface
+			command-line-absyn-interface
+			command-line-absyn-constructors-interface)))
+  (open scheme
+	extended-ports
+	define-record-types
+	(subset srfi-1 (filter))
+	srfi-6
+	srfi-8
+	(subset srfi-13 (string-join))
+	srfi-14
+	silly
+	signals 
+	handle)
+  (files cmdline))
+   
 ;;; nuit 
 
 (define-interface nuit-interface