Permalink
Browse files

Added parse-args macro. It currently works on all

implementations but clisp.
  • Loading branch information...
1 parent 9de0f93 commit 168b2a22854db0ce4c3cf85bdc9c9e2c71aeac65 @jrockytop committed May 21, 2012
Showing with 277 additions and 11 deletions.
  1. +2 −0 .gitignore
  2. +8 −2 Makefile
  3. +8 −2 README
  4. +10 −7 main.c
  5. +242 −0 parse-args.lisp
  6. +7 −0 test.lisp
View
@@ -0,0 +1,2 @@
+*.o
+*~
View
@@ -1,15 +1,21 @@
INSTALL_DIR=/usr/local/bin
CFLAGS=-I. -O2 -Wall
-OBJS=main.o
+OBJS=main.o parse_args.o
all: cl
cl: $(OBJS)
$(CC) -o cl $(OBJS)
+parse_args.c: parse-args.lisp
+ @echo 'char *parse_args = ' > parse_args.c
+ @sed 's/\\/\\\\/g' < parse-args.lisp | sed 's/;.*//g' | sed 's/"/\\"/g' | sed 's/$$/"/g' | sed 's/^/"/g' | sed 's/%/%%/g' | sed 's/^"[ \t]*"/""/g' | grep -v '^""' >> parse_args.c
+ @echo ';\n' >> parse_args.c
+
+
install: cl
install -c cl $(INSTALL_DIR)/cl
clean:
- rm -f *.o cl
+ rm -f *.o parse_args.c cl
View
10 README
@@ -7,7 +7,7 @@ readline interface for interactive sessions. So, make sure you have
rlwrap installed. Also, make sure you have a supported lisp
implementation installed too. :-)
-The program currently works with SBCL, CCL, and ECL. More
+The program currently works with SBCL, CCL, CLISP and ECL. More
implementations will probably be added in the future.
To support #! functionality, the #! macro character is set to ignore
@@ -16,10 +16,16 @@ conflict.
cl also sets up the global variable *args* with the argument list
passed to the lisp script. The script name is set to *program-name*.
-I'm still decideing if these are the best names to use, so they might
+I'm still deciding if these are the best names to use, so they might
possibly change in the future. But, they don't seem to cause any
conflicts in my testing so far.
+To parse the argument list, a macro named parse-args is defined. It
+takes a list of options. Each option consists of a list with 3
+strings: the short-option name + argument (if needed), the long-option
+name, and a description of the option. See the test.lisp script for
+an example use of parse-args.
+
When running scripts, the lisp implementation will have its debugger
turned off. So if there are any errors in your script, the script
will exit with whatever message the lisp implementation prints and
View
17 main.c
@@ -35,6 +35,8 @@
#include <getopt.h>
#include <string.h>
+extern char *parse_args;
+
/* The common lisp magic for #! acceptance */
char *shebang = "(set-dispatch-macro-character #\\# #\\!"
" (lambda (s c n)"
@@ -77,15 +79,15 @@ void invoke_lisp_repl(char *lisp)
}
if (!strcmp("sbcl", lisp)) {
- execlp("rlwrap", "sbcl", "sbcl", "--eval", shebang, NULL);
+ execlp("rlwrap", "sbcl", "sbcl", "--eval", shebang, "--eval", parse_args, NULL);
}
if (!strcmp("ccl", lisp) || !strcmp("ccl64", lisp)) {
- execlp("rlwrap", lisp, lisp, "-e", shebang, NULL);
+ execlp("rlwrap", lisp, lisp, "-e", shebang, "-e", parse_args, NULL);
}
if (!strcmp("ecl", lisp)) {
- execlp("rlwrap", "ecl", "ecl", "-q", "-eval", shebang,
+ execlp("rlwrap", "ecl", "ecl", "-q", "-eval", shebang, "-eval", parse_args,
"-eval", "(setf *load-verbose* nil asdf:*asdf-verbose* nil)", NULL);
}
@@ -110,26 +112,27 @@ void run_script(char *lisp, char *script, char *args)
if (!strcmp("sbcl", lisp)) {
execlp("sbcl", "sbcl", "--noinform", "--disable-debugger", "--eval", name,
- "--eval", args, "--eval", shebang, "--load", script, "--eval", "(quit)", NULL);
+ "--eval", args, "--eval", shebang, "--eval", parse_args,
+ "--load", script, "--eval", "(quit)", NULL);
}
if (!strcmp("ccl", lisp) || !strcmp("ccl64", lisp)) {
char *nodebug = "(setf *debugger-hook* (lambda (x y)"
"(declare (ignore y)) (describe x)(quit)))";
execlp(lisp, lisp, "-Q", "-e", shebang, "-e", name, "-e", args,
- "-e", nodebug, "-l", script, "-e", "(quit)", NULL);
+ "-e", nodebug, "-e", parse_args, "-l", script, "-e", "(quit)", NULL);
}
if (!strcmp("ecl", lisp)) {
execlp("ecl", "ecl", "-q",
"-eval", "(setf *load-verbose* nil asdf:*asdf-verbose* nil)",
- "-eval", shebang, "-eval", name, "-eval", args,
+ "-eval", shebang, "-eval", name, "-eval", args, "-eval", parse_args,
"-shell", script, NULL);
}
if (!strcmp("clisp", lisp)) {
- char *expressions = concatenate(name, args, shebang, NULL);
+ char *expressions = concatenate(name, args, shebang, parse_args, NULL);
char load[strlen(expressions) + strlen(script) + 128];
snprintf(load, sizeof(load),
"(progn %s (load \"%s\")"
View
@@ -0,0 +1,242 @@
+;;;;
+;;;; Copyright (c) 2012, Jason Wade Cox <jason@coxmountain.com>
+;;;; All rights reserved.
+;;;;
+;;;; Redistribution and use in source and binary forms, with or without
+;;;; modification, are permitted provided that the following conditions
+;;;; are met:
+;;;;
+;;;; Redistributions of source code must retain the above copyright
+;;;; notice, this list of conditions and the following disclaimer.
+;;;;
+;;;; Redistributions in binary form must reproduce the above copyright
+;;;; notice, this list of conditions and the following disclaimer in
+;;;; the documentation and/or other materials provided with the
+;;;; distribution.
+;;;;
+;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
+;;;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+;;;; COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
+;;;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+;;;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+;;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+;;;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+;;;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
+;;;; OF THE POSSIBILITY OF SUCH DAMAGE.
+;;;;
+
+;;;
+;;; parse-args
+;;;
+;;; This macro parses arguments from the *args* global variable. It
+;;; takes a list of options to parse in the following format:
+;;;
+;;; (short-option-string & option argument, long-option-string, description)
+;;;
+;;; Example parse-args options:
+;;; (parse-args (("v" "verbose" "The verbose flag")
+;;; ("f <filename>" "file" "The file option")
+;;; ("q" "quit" "Quit"))
+;;;
+;;; The macro will create variables based on the long-option string.
+;;; For instance in the example, the variables 'flag-verbose',
+;;; 'flag-file', and 'flag-quit' will be created. Options that don't
+;;; take arguments will be set to the number of times the option
+;;; appears or to nil if the option wasn't set. Options that take
+;;; arguments will be set to the corresponding last argument that
+;;; appears or nil if the option did not appear.
+;;;
+;;; The non-flag arguments are in the variable 'parsed-args'
+;;;
+;;; A help flag and help message are automatically generated.
+;;;
+(defmacro parse-args (opts &body body)
+ ;; Too lazy to type help options... add it automatically...
+ ;; unless somebody already added it on their own...
+ (pushnew '("h" "help" "Display help")
+ opts :test (lambda (x y)
+ (string= (car x) (car y))))
+ (labels (
+ ;;;
+ ;;; Return the flag-name for an option entry
+ ;;;
+ (flag-name (entry)
+ (intern (string-upcase (concatenate 'string "flag-" (second entry)))))
+
+ ;;;
+ ;;; Return a list of all flag-names given the list of options
+ ;;;
+ (flag-names (opts)
+ (let (list)
+ (dolist (i opts)
+ (push (flag-name i) list))
+ (push 'parsed-args list)
+ (pushnew 'flag-help list)
+ list))
+
+ ;;;
+ ;;; Generate code to setq the flag variables
+ ;;;
+ (set-strings (opts var)
+ (let ((l '(case (second f))))
+ (dolist (i opts)
+ (setf l (append l (list (list (second i) (list 'setq (flag-name i) var))))))
+ l)))
+
+ `(let ,(flag-names opts)
+ (labels (
+ ;;;
+ ;;; This function takes a string and returns whether the
+ ;;; string is an arg, long-option, short-option, or
+ ;;; expandable-short-options
+ ;;;
+ (element-type (element)
+ (if (or (< (length element) 2) (string= "--" element))
+ 'arg
+ (case (count #\- element :end 2)
+ (0 'arg)
+ (1 (if (> (length element) 2)
+ 'expandable-short-options
+ 'short-option))
+ (2 'long-option))))
+
+ ;;;
+ ;;; Return the short option given the option entry
+ ;;;
+ (entry-to-short-option (x)
+ (concatenate 'string "-" (subseq (first x) 0 1)))
+
+ ;;;
+ ;;; Return the long option given the option entry
+ ;;;
+ (entry-to-long-option (x)
+ (concatenate 'string "--" (second x)))
+
+ ;;;
+ ;;; Return t if the entry takes an optional argument, otherwise nil
+ ;;;
+ (entry-takes-arg (entry)
+ (> (length (first entry)) 1))
+
+ ;;;
+ ;;; Find option
+ ;;;
+ (find-option (opts-list option type)
+ (let ((test (if (eq type 'short-option)
+ (lambda (x y)
+ (string= x (entry-to-short-option y)))
+ (lambda (x y)
+ (string= x (entry-to-long-option y))))))
+ (find option opts-list :test test)))
+
+ ;;;
+ ;;; Given an option, return nil or t depending on if the
+ ;;; given option takes an argument or not
+ ;;;
+ (option-takes-arg (opts-list option type)
+ (entry-takes-arg (find-option opts-list option type)))
+
+ ;;;
+ ;;; This function expands a short option element into a
+ ;;; list of short options. If a short option takes an
+ ;;; argument, the rest of the element will be its
+ ;;; argument. ie: for an option -f that takes an argument,
+ ;;; "-vvfarg" will be expanded to ("-v" "-v" "-f" "arg")
+ ;;;
+ (expand-short-options (opts element)
+ (labels ((expand (opts element)
+ (let (list)
+ (when (> (length element) 1)
+ (let ((option (concatenate 'string "-"
+ (string (elt element 1))))
+ (rest (subseq element 2)))
+ (push option list)
+ (if (option-takes-arg opts option 'short-option)
+ (if (> (length rest) 0)
+ (push rest list)
+ list)
+ (nconc (expand opts (concatenate 'string
+ "-" rest)) list)))))))
+ (reverse (expand opts element))))
+
+ ;;;
+ ;;; Set the option flags given the options and the parsed flags
+ ;;;
+ (set-flags (opts flags)
+ (dolist (f opts)
+ (if (entry-takes-arg f)
+ (let ((pos (position f flags :from-end t
+ :test (lambda (x y)
+ (or (string= y (entry-to-short-option x))
+ (string= y (entry-to-long-option x)))))))
+ (when pos
+ ,(set-strings opts '(elt flags (1+ pos)))))
+ (let ((num (count f flags
+ :test (lambda (x y)
+ (or (string= y (entry-to-short-option x))
+ (string= y (entry-to-long-option x)))))))
+ (when (> num 0)
+ ,(set-strings opts 'num))))))
+
+ ;;;
+ ;;; Help usage
+ ;;;
+ (help (opts)
+ (let ((list (sort (copy-list opts) (lambda (x y)
+ (string< (car x) (car y))))))
+ (dolist (i list)
+ (format *error-output* "~a, ~a ~35t~a~&" (entry-to-long-option i)
+ (concatenate 'string "-" (first i)) (third i))))
+ (quit))
+
+ ;;;
+ ;;; Parse the arguments
+ ;;;
+ (parse-args-function (opts args)
+ (labels ((normalize (opts args)
+ (let (list)
+ (when args
+ (let* ((element (first args))
+ (rest (rest args))
+ (type (element-type element)))
+ (cond
+ ((eq type 'expandable-short-options)
+ (normalize opts
+ (append (expand-short-options opts element) rest)))
+
+ ((eq type 'arg)
+ (setf parsed-args args)
+ nil)
+
+ (t ;; Options
+ (unless (find-option opts element type)
+ (format *error-output* "invalid option -- ~A~&"
+ (subseq element 1))
+ (error 'die))
+
+ (if (option-takes-arg opts element type)
+ (progn
+ (push element list)
+ (unless rest
+ (format *error-output*
+ "option requires an argument -- ~A~&"
+ (subseq element 1))
+ (error 'die))
+ (push (first rest) list)
+ (append (normalize opts (rest rest)) list))
+ (progn
+ (push element list)
+ (append (normalize opts rest) list))))))))))
+
+ (set-flags opts (reverse (normalize opts args)))
+ (if flag-help
+ (help opts)))))
+ (handler-case
+ (parse-args-function ',opts *args*)
+ (error (e)
+ (declare (ignore e))
+ (help ',opts))))
+ ,@body)))
View
@@ -8,3 +8,10 @@
(write-line (lisp-implementation-version))
;(print (require 'cffi))
;fail
+
+(parse-args (("v" "verbose" "Set verbose flag")
+ ("f <FILE>" "file" "Specify a file argument"))
+ (format t "flag-help = ~A~%" flag-help)
+ (format t "flag-verbose = ~A~%" flag-verbose)
+ (format t "flag-file = ~A~%" flag-file)
+ (format t "parsed-args = ~S~%" parsed-args))

0 comments on commit 168b2a2

Please sign in to comment.