cl-awk 1-3 / usr / share / common-lisp / source / clawk / clawk.lisp

;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CLAWK; Base: 10 -*-

(in-package :CLAWK)


;;;
;;; change the #/.../ readmacro to generate a regex-matcher object,
;;; and use the make-load-form function to define the loader and initializer
;;;

;;;
;;; reader macro for #/.../ regex symbols
;;;

(defun |#/-reader| (strm subchar arg)
  (declare (ignore subchar arg))
  (let ((symname ""))
    (loop 
     (let ((c (read-char strm)))
       (cond ((char= c #\/)
              (return-from |#/-reader|
                (list 'quote (intern symname *package*))))
             ((char= c #\\)
              (let ((c2 (read-char strm)))
                (cond ((char= c2 #\/)
                       (setq symname (concatenate 'string symname (string #\/))))
                      ((or (char= c2 #\n) (char= c2 #\N)
                           (char= c2 #\r) (char= c2 #\R)
                           (char= c2 #\t) (char= c2 #\T))
                       (setq symname (concatenate 'string symname (string c) (string c2))))
                      ((digit-char-p c2)
                       (setq symname (concatenate 'string symname (string c) (string c2))))
                      (t (setq symname (concatenate 'string symname (string c2)))))))
             ((or (char= c #\Return) (char= c #\Newline))
              (error "Unterminated regular expression: " symname))
             (t (setq symname (concatenate 'string symname (string c)))))))))

(defun install-regex-syntax ()
  (set-dispatch-macro-character #\# #\/ #'|#/-reader|)
  t)

#-:Symbolics
(progn

(defun |#`-reader| (strm subchar arg)
  (declare (ignore subchar arg))
  (let ((cmdname-strm (make-string-output-stream)))
    (loop
     (let ((c (read-char strm)))
       (cond ((char= c #\`)
              (return-from |#`-reader| `(call-system-catching-output ,(get-output-stream-string cmdname-strm))))
             ((char= c #\\)
              (let ((c2 (read-char strm)))
                (cond ((char= c2 #\`)
                       (princ c2 cmdname-strm))
                      (t (princ c cmdname-strm)
                         (princ c2 cmdname-strm)))))
             ((or (char= c #\Return) (char= c #\Newline))
              (error "Unterminated shell command: " (get-output-stream-string cmdname-strm)))
             (t (princ c cmdname-strm)))))))

(defun install-cmd-syntax ()
  (set-dispatch-macro-character #\# #\` #'|#`-reader|)
  t)

)

;(defun test ()
;  (for-stream-lines (#`command.com /c dir`)
;    ($print *FNR* " " $0)))



#+Lispworks
(progn
  
(defun call-system-catching-output (cmd)
  (let ((cmd-output (make-string-output-stream)))
    (sys:call-system-showing-output cmd
                                    :prefix ""
                                    :output-stream cmd-output
                                    :wait t
                                    :show-cmd nil)
    (make-string-input-stream (get-output-stream-string cmd-output))))

(defun get-shell-pgm ()
  (or (lispworks:environment-variable "COMSPEC")
      (lispworks:environment-variable "SHELL")
      (lispworks:environment-variable "shell")))

)



(defgeneric get-matcher-for-pattern (pattern))
(defmethod get-matcher-for-pattern ((pattern symbol))
  (let ((matcher (get pattern 'regex-matcher)))
    (if matcher
        matcher
      (let ((matcher (compile-str (symbol-name pattern))))
        (if matcher
            (setf (get pattern 'regex-matcher) matcher))
        matcher))))
(defmethod get-matcher-for-pattern ((pattern string))
  (compile-str pattern))
(defmethod get-matcher-for-pattern ((pattern matcher))
  pattern)




(defvar *CURFILE*)
(defvar *CURLINE* "")
(defvar *FS* "[ \\t]+")
(defvar *RSTART* 0)
(defvar *RLENGTH* 0)
(defvar *REND* 0)
(defvar *REGS* (make-array 0))
(defvar *FIELDS* (make-array 0))
(defvar *NR* 0)                         ; total num recs read
(defvar *FNR* 0)                        ; num recs read in current file
(defvar *NF* 0)                         ; number of fields in current record
(defvar *SUBSEP* (string (code-char #o34)))
(defvar *OFS* " ")
(defvar *ORS* "\n")
(defvar *LAST-SUCCESSFUL-MATCH*)

(define-symbol-macro $0 *curline*)
(define-symbol-macro $1 ($n 1))
(define-symbol-macro $2 ($n 2))
(define-symbol-macro $3 ($n 3))
(define-symbol-macro $4 ($n 4))
(define-symbol-macro $5 ($n 5))
(define-symbol-macro $6 ($n 6))
(define-symbol-macro $7 ($n 7))
(define-symbol-macro $8 ($n 8))
(define-symbol-macro $9 ($n 9))
(define-symbol-macro $10 ($n 10))
(define-symbol-macro $11 ($n 11))
(define-symbol-macro $12 ($n 12))
(define-symbol-macro $13 ($n 13))
(define-symbol-macro $14 ($n 14))
(define-symbol-macro $15 ($n 15))
(define-symbol-macro $16 ($n 16))
(define-symbol-macro $17 ($n 17))
(define-symbol-macro $18 ($n 18))
(define-symbol-macro $19 ($n 19))
(define-symbol-macro $20 ($n 20))

(define-symbol-macro %0 (%n 0))
(define-symbol-macro %1 (%n 1))
(define-symbol-macro %2 (%n 2))
(define-symbol-macro %3 (%n 3))
(define-symbol-macro %4 (%n 4))
(define-symbol-macro %5 (%n 5))
(define-symbol-macro %6 (%n 6))
(define-symbol-macro %7 (%n 7))
(define-symbol-macro %8 (%n 8))
(define-symbol-macro %9 (%n 9))
(define-symbol-macro %10 (%n 10))
(define-symbol-macro %11 (%n 11))
(define-symbol-macro %12 (%n 12))
(define-symbol-macro %13 (%n 13))
(define-symbol-macro %14 (%n 14))
(define-symbol-macro %15 (%n 15))
(define-symbol-macro %16 (%n 16))
(define-symbol-macro %17 (%n 17))
(define-symbol-macro %18 (%n 18))
(define-symbol-macro %19 (%n 19))
(define-symbol-macro %20 (%n 20))


(defun FS ()
  (if (stringp *FS*)
      (setq *FS* (get-matcher-for-pattern *FS*))
    *FS*))




;;;
;;; STR
;;;
(defgeneric str (x))
(defmethod str ((x string))
  x)
(defmethod str ((x (eql nil)))
  "")
(defmethod str ((x number))
  (format nil "~D" x))



;;;
;;; NUM
;;;
(defgeneric num (x))
(defmethod num ((x number))
  x)
(defmethod num ((x (eql nil)))
  0)
(defmethod num ((x string))
  (let ((val (read (make-string-input-stream x))))
    (if (numberp val)
	val
	0)))

;;;
;;; INT
;;;
(defgeneric int (x))
(defmethod int ((x integer))
  x)
(defmethod int ((x number))
  (round x))
(defmethod int ((x (eql nil)))
  0)
(defmethod int ((x string))
  (let ((val (read (make-string-input-stream x) nil 0)))
    (if (numberp val)
	(round val)
	0)))

;;;
;;; SUB
;;;
;;; Substitute the first occurrence of pattern.
;;;
(defun sub (pattern replacement &optional (source *CURLINE*))
  "Replace the first occurrence of pattern in the source string."
  (let ((matcher (get-matcher-for-pattern pattern))
        (srclen (length source)))
    (multiple-value-bind (matchedp matchstart matchlen)
        (regex:scan-str matcher source :start 0 :length srclen)
      (if matchedp
          (concatenate 'string (subseq source 0 matchstart)
                       replacement
                       (subseq source (+ matchstart matchlen) srclen))
        source))))

(defun $sub (pattern replacement &optional (source *CURLINE*))
  "Replace the first occurrence of pattern in the source string.
   Coerces its arguments to the appropriate type."
  (sub pattern (str replacement) (str source)))


;;;
;;; GSUB
;;;
;;; Globally substitute all occurrences of pattern.
;;;
(defun gsub (pattern replacement &optional (source *CURLINE*))
  "Replace all occurrences of pattern in the source string."
  (let* ((matcher (get-matcher-for-pattern pattern))
         (total-len (length source))
         (len-remaining total-len)
         (new-string "")
         (matchedp t)
         (prior-end 0)
         (match-start 0)
         (match-len 0))
    (loop
      (multiple-value-setq (matchedp match-start match-len)
        (regex:scan-str matcher source :start match-start :length len-remaining))
      (if matchedp
          (setf new-string (concatenate 'string new-string
                                        (subseq source prior-end match-start)
                                        replacement)
                prior-end (+ match-start match-len)
                match-start prior-end
                len-remaining (- total-len match-start))
        (return-from gsub
          (concatenate 'string
                       new-string
                       (subseq source prior-end total-len)))))))

(defun $gsub (pattern replacement &optional (source *CURLINE*))
  "Replaces all occurrences of pattern in the source string.
   Coerces its arguments to the appropriate type."
  (gsub pattern (str replacement) (str source)))


;;;
;;; SPLIT
;;;
;;; Splits a string up based on an optional field separator pattern
;;; (uses *FS* as a default).  If no string is supplied, it will split
;;; *CURLINE* and set *FIELDS* and the various $n variables.
;;;
(defun split (&optional (source nil not-splitting-curline) (fieldsep-pattern (FS)))
  "Split a string up into a list of multiple fields based on
   the field-separator pattern."
  (when (or (null source) (eq source *CURLINE*))
    (setf source *CURLINE*
          not-splitting-curline nil))
  (let* ((fieldsep-matcher (get-matcher-for-pattern fieldsep-pattern))
         (fields nil)
         (total-len (length source))
         (len-remaining (length source))
         (matchedp t)
         (prior-end 0)
         (match-start 0)
         (match-len 0))
    (loop
     (multiple-value-setq (matchedp match-start match-len)
         (regex:scan-str fieldsep-matcher source :start match-start :length len-remaining))
     (cond (matchedp
            ;; don't push an empty string if the first thing we
            ;; find is a separator
            (when (> match-start 0)
              (push (subseq source prior-end match-start)
                    fields))
            ;; now step over this match and continue splitting
            (setf prior-end (+ match-start match-len)
                  match-start prior-end
                  len-remaining (- total-len match-start)) )
           (t
            (when (< prior-end total-len)
              (push (subseq source prior-end match-len) fields))
            (setf fields (nreverse fields))
            (unless not-splitting-curline
              (setf *FIELDS* (make-array (length fields) :initial-contents fields)))
            (return-from split fields))))))


(defun $split (&optional (source nil source-supplied-p) (fieldsep-pattern (FS)))
  "Split a string up into a list of multiple fields based on
   the field-separator pattern.  Coerces its arguments to the appropriate type."
  (split (if (and source source-supplied-p) (str source) source)
	 fieldsep-pattern))


;;;
;;; MATCH
;;;
;;; Searches for the first occurrence of a pattern in a string.
;;; Takes an optional offset.  If successful, sets *RSTART*,
;;; *RLENGTH*, *REND*, and *REGS*.
;;;
(defun match (source pattern &optional (start 0))
  "Scan for first occurrence of a pattern within the source string."
  (let ((matcher (get-matcher-for-pattern pattern)))
    (multiple-value-bind (matchedp start len regs)
        (regex:scan-str matcher source :start start :length (- (length source) start)
                  :start-is-anchor t :end-is-anchor t)
      (when matchedp
        (setf *RSTART* start
              *RLENGTH* len
              *REND* (+ start len)
              *REGS* regs
	      *LAST-SUCCESSFUL-MATCH* source))
      matchedp)))

(defun $match (source pattern &optional (start 0))
  "Scan for first occurrence of a pattern within the source string.
   Coerces its arguments to the appropriate type."
  (match (str source) pattern (int start)))


;;;
;;; INDEX
;;;
;;; Searches for the first occurrence of a substring within a string.
;;; Takes an optional offset.
;;;
(declaim (inline index))
(defun index (pat str &optional (start 0))
  (search pat str :start2 start))

(defun $index (pat str &optional (start 0))
  (index (str pat) (str str) (int start)))


;;;
;;; SUBSTR
;;;
;;; Extract a substring.  Like subseq, but takes length instead of end.
;;;
(declaim (inline substr))
(defun substr (str start len)
  (subseq str start (+ start len)))

(defun $substr (str start len)
  (substr (str str) (int start) (int len)))


;;;
;;; ~ !~ /~
;;;
;;; test if string contains the pattern
;;;
(defun ~ (pattern string)
  "Test if pattern matches the string."
  (let* ((matcher (get-matcher-for-pattern pattern))
	 (string (str string)))
    (multiple-value-bind (matchedp)
        (regex:scan-str matcher string
			 :start 0 :length (length string)
			 :start-is-anchor t :end-is-anchor t)
      matchedp)))

(declaim (inline /~))
(defun /~ (pattern string)
  "Test if pattern isn't present in the string."
  (not (~ pattern string)))

(declaim (inline !~))
(defun !~ (pattern string)
  "Test if pattern isn't present in the string."
  (/~ pattern string))



;;;
;;; WITH-PATTERNS
;;;
(defmacro with-patterns (pats &rest body)
  "Execute the body in an environment that includes the compiled patterns
   bound to their respective variables."
  #+Symbolics (declare (zwei:indentation 1 1))
  (expand-with-patterns pats `(progn ,@body)))
#+:Lispworks (editor:setup-indent "with-patterns" 1 2 6)

(defun expand-with-pattern (var strpat body)
  `(let ((,var (get-matcher-for-pattern ,strpat)))
     (when ,var
       (locally
        (declare (type matcher ,var))
        ,body))) )

(defun expand-with-patterns (pats body)
  (if pats
      (expand-with-pattern (caar pats) (cadar pats)
                           (expand-with-patterns (cdr pats) body))
    body))



;;;
;;; WITH-FIELDS
;;;
;;; Allows stuff like
;;;   (with-fields ((a b c d &rest rest) str)
;;;     ($print "Fields:" a b c d "Rest: " rest))
;;;
;;; as well as the slightly more awk-ish
;;;   (with-fields (nil str)
;;;     ($print "Fields:" $1 $2 $3 $4))
;;; which splits STR into the $ vars,
;;; 
;;; or even
;;;   (with-fields ()
;;;     ($print "Fields:" $1 $2 $3 $4))
;;; which will split the current line into the $ vars.
;;;
(defmacro with-fields ((&optional fields sourcestr (fieldsep-pattern '(FS))) &rest body)
  "Split the source string into fields based on the field separator,
   bind the field array to the fields variable."
  #+Symbolics (declare (zwei:indentation 1 1))
  (expand-with-fields fields sourcestr fieldsep-pattern body))
#+:Lispworks (editor:setup-indent "with-fields" 1 2 6)

(defun expand-with-fields (fields sourcestr fieldsep-pattern body)
  (let ((tmp-splits (gensym)))
    (if (null fields)
        `(let (*FIELDS*)
           (let* ((,tmp-splits (split ,sourcestr ,fieldsep-pattern))
                  (*NF* (length ,tmp-splits)))
             ,@body))
      `(let* ((,tmp-splits (split ,sourcestr ,fieldsep-pattern))
              (*NF* (length ,tmp-splits)))
         (declare (special *NF*))
         (destructuring-bind ,fields ,tmp-splits
           ,@body)))))



;;;
;;; $
;;;
;;; Field access to a computed field
;;;
(defun $n (n)
  "Access a field."
  (let ((n (int n)))
    (cond ((zerop n) *CURLINE*)
          ((and (>= n 0) (<= n (array-dimension *FIELDS* 0)))
           (aref *FIELDS* (1- n))))))

(defsetf $n (n) (val)
  (let ((tmpvar (gensym)))
    `(let ((,tmpvar (int ,n)))
       (cond ((zerop ,tmpvar) (setf *CURLINE* ,val))
             ((and (>= ,tmpvar 0) (<= ,tmpvar (array-dimension *FIELDS* 0)))
              (setf (aref *FIELDS* (1- ,tmpvar)) ,val))))))



;;;
;;; WITH-SUBMATCHES
;;;
;;; Allows stuff like
;;;   (with-submatches (a b c d)
;;;     ($print "Regs:" a b c d))
;;;
;;; which is handy in match-case clauses
;;;
(defmacro with-submatches (&optional fields &rest body)
  "Bind the submatch variables to the corresponding strings from the registers array."
  #+Symbolics (declare (zwei:indentation 1 1))
  (expand-with-submatches fields body))
#+:Lispworks (editor:setup-indent "with-submatches" 1 2 6)

(defun expand-with-submatches (fields body)
  (if fields
      `(destructuring-bind ,fields
           (make-register-list *LAST-SUCCESSFUL-MATCH* *REGS*)
	 ,@body)
      `(progn ,@body)))



;;;
;;; IF-MATCH
;;;
;;; Allows stuff like
;;;   (if-match ("a*b" str)
;;;     ($print "Regs:" %0 %1 %2 %3 %4)
;;;     ($print "No match")
;;;
(defmacro if-match ((pat str &optional (pos 0)) consequent alternative)
"Match the pattern to the string, and if it matches, bind the
*RSTART*, *RLENGTH*, and *REGS* and evaluate the consequent,
otherwise evaluate the alternative."
  #+Symbolics (declare (zwei:indentation 1 1))
  (expand-if-match pat str pos consequent alternative))
#+:Lispworks (editor:setup-indent "if-match" 2 2 4)


(defun expand-if-match (pat str pos consequent alternative)
  (once-only (str pos)
    `(multiple-value-bind (matchedp *RSTART* *RLENGTH* *REGS*)
         (regex:match-str (get-matcher-for-pattern ,pat)
                          ,str :start ,pos)
       (if matchedp
           (let ((*last-successful-match* ,str))
             ,consequent)
         ,alternative))))


;;;
;;; WITH-MATCH
;;;
;;; Allows stuff like
;;;   (with-match ((a b c d &rest rest) pat str)
;;;     ($print "Regs:" a b c d "Rest: " rest))
;;;
;;; as well as the slightly less readable
;;;   (with-match (nil pat str)
;;;     ($print "Regs:" %1 %2 %3 %4))
;;; which matches pat against str, and loads the submatches into the % vars,
;;; 
;;; or even
;;;   (with-match (nil pat)
;;;     ($print "Fields:" %1 %2 %3 %4))
;;; which will split the current line into the % vars.

(defmacro with-match ((&optional fields pat sourcestr) &rest body)
  "Split the source string into registers based on the pattern,
   bind the register variables to the registers array."
 #+Symbolics (declare (zwei:indentation 1 1))
  (expand-with-match pat fields sourcestr body))
#+:Lispworks (editor:setup-indent "with-match" 1 2 6)

(defun expand-with-match (pat fields sourcestr body)
  (cond ((and pat fields)
	 `(when (match (or ,sourcestr *CURLINE*) ,pat)
	    (destructuring-bind ,fields (make-register-list *LAST-SUCCESSFUL-MATCH* *REGS*)
	      ,@body)))
	((and pat (null fields))
	 `(let (*LAST-SUCCESSFUL-MATCH* *REGS*)
	    (declare (special *LAST-SUCCESSFUL-MATCH* *REGS*))
	    (when (match (or ,sourcestr *CURLINE*) ,pat)
	      ,@body)))
	((and (null pat) fields (null sourcestr))
	 `(destructuring-bind ,fields
	      (make-register-list *LAST-SUCCESSFUL-MATCH* *REGS*)
	    ,@body))
	((and (null pat) (null fields) sourcestr)
	 (error "WITH-MATCH requires a pattern to match the string ~A against" sourcestr))
	((and (null pat) (null fields) (null sourcestr))
	 `(progn ,@body))))

(defun make-register-list (str regs)
  (let ((nregs (array-dimension regs 0)))
    (loop for i from 0 below nregs
	  collect (get-reg-str str regs i))))


;;;
;;; %
;;;
;;; Register access
;;;

(defun get-reg-str (str regs n)
  "Access a register."
  (let ((rstart (register-start regs n))
	(rend (register-end regs n)))
    (if (and (numberp rstart) (numberp rend))
	(subseq str rstart rend))))

(defun %n (n)
  "Access a register."
  (let ((n (int n)))
    (if (and (stringp *LAST-SUCCESSFUL-MATCH*) (< n (array-dimension *REGS* 0)) (>= n 0))
	(get-reg-str *LAST-SUCCESSFUL-MATCH* *REGS* n))))



;;;
;;; MATCH-CASE
;;;
;;; Allows stuff like:
;;; (match-case str
;;;   (#/foo/ (format t "foo"))
;;;   (#/bar/ (format t "bar"))
;;;   ((#/baz/ #/qux/) (format t "either baz or qux"))
;;;   (else (format t "unknown")))
;;;
;;; The matches are done by MATCH, so the various special variables are set
;;; appropriately
;;;
(defmacro match-case (strexpr &rest clauses)
  #+Symbolics (declare (zwei:indentation 1 1))
  (expand-match-case strexpr clauses))
#+:Lispworks (editor:setup-indent "match-case" 1 2 6)

(defun expand-match-case (strexpr clauses)
  (let ((tmpstrsym (gensym)))
    `(let ((,tmpstrsym ,strexpr))
       ,(expand-match-case-clauses tmpstrsym clauses))))

(defun expand-match-case-clauses (strexpr clauses)
  (if clauses
      (let ((clause (first clauses))
            (other-clauses (rest clauses)))
        (cond ((member (car clause) '(t else otherwise))
               `(progn ,@(rest clause)))
              ((atom (car clause))
               `(if (match ,strexpr ,(car clause))
                    (progn ,@(cdr clause))
                  ,(expand-match-case-clauses strexpr other-clauses)))
              (t `(if (or ,@(mapcar #'(lambda (x) `(,strexpr match ,x)) clause))
                      (progn ,@(cdr clause))
                    ,(expand-match-case-clauses strexpr other-clauses)))))
    `()))




;;;
;;; MATCH-WHEN
;;;
;;; Takes a set of clauses that correspond to the AWK toplevel forms,
;;; but just evaluates the clauses (BEGIN clause first, then pattern
;;; clauses, then END clause), without any looping.
;;;
(defmacro match-when (&rest clauses)
  #+Symbolics (declare (zwei:indentation 1 1))
  (let ((docs-and-decs (extract-docs-and-decs clauses))
        (begin-clauses (extract-begin-clauses clauses))
        (end-clauses (extract-end-clauses clauses))
        (pattern-clauses (extract-pattern-clauses clauses)))
    `(locally ,@docs-and-decs
              (progn ,@(mapcan #'rest begin-clauses)
                     ,@(mapcar #'expand-match-when-clause pattern-clauses)
                     ,@(mapcar #'rest end-clauses)))))
#+:Lispworks (editor:setup-indent "match-when" 0 2)

(defun is-special-clause (clause type)
  (and (listp clause)
       (symbolp (first clause))
       (string-equal (symbol-name (first clause)) type)))


(defun extract-docs-and-decs (clauses)
  (loop for clause in clauses
        while (or (stringp clause) (is-special-clause clause "DECLARE"))
        collect clause))

(defun extract-begin-clauses (clauses)
  (loop for clause in clauses
        when (is-special-clause clause "BEGIN")
             collect clause))

(defun extract-end-clauses (clauses)
  (loop for clause in clauses
        when (is-special-clause clause "END")
             collect clause))

(defun extract-pattern-clauses (clauses)
  (loop for clause in clauses
        unless (or (not (listp clause))
                   (is-special-clause clause "BEGIN")
                   (is-special-clause clause "END")
                   (is-special-clause clause "DECLARE"))
             collect clause))

;
; (t . body) --> (progn . body)
; (nil . body) --> (progn . body)
; ((quote sym) . body) --> (when (match *CURLINE* (quote sym)) . body)
; (stringlit . body) --> (when (match *CURLINE* stringlit) . body)
; (form . body) --> (when form . body)
;
(defun expand-match-when-clause (clause)
  (cond ((null clause) nil)
        ((stringp (first clause))
         `(when (match *CURLINE* ,(first clause))
            ,@(expand-match-when-consequent (rest clause))))
        ((member (first clause) '("t" "always") :test #'symbol-name-eq)
         (rest clause))
        ((atom (first clause))
         `(when ,(first clause)
            ,@(expand-match-when-consequent (rest clause))))
        (t (let ((condition (first clause))
                 (consequents (rest clause)))
             (if (eq (first condition) 'quote)
                 `(when (match *CURLINE* ,condition)
                    ,@(expand-match-when-consequent consequents))
               `(when ,condition
                  ,@(expand-match-when-consequent consequents)))))))

; provide the default action if one isn't present
(defun expand-match-when-consequent (consequent)
  (if consequent
      consequent
    '(($print *CURLINE*))))

; sym-name-eq
(defun symbol-name-eq (x y)
  (if (symbolp x)
      (if (symbolp y)
          (string= (symbol-name x) (symbol-name y))
        (if (stringp y)
            (string= (symbol-name x) y)))
    (if (stringp x)
        (if (symbolp y)
            (string= x (symbol-name y))
          (if (stringp y)
              (string= x y))))))

;;;
;;; FOR-STREAM-LINES
;;;
;;; Iterate the body over the lines of the stream.  Don't split the
;;; lines, but keep the current line in both *CURLINE* and $0.
;;;
(defmacro for-stream-lines ((stream &optional (strmvar (gensym))
                                              (linevar (gensym)))
                                    &rest body)
  #+Symbolics (declare (zwei:indentation 1 1))
  (expand-for-stream-lines strmvar linevar stream body))
#+:Lispworks (editor:setup-indent "for-stream-lines" 1 2 6)

(defun expand-for-stream-lines (streamvar linevar stream body
                                          &aux (nextlbl (gensym)))
  `(let ((,streamvar ,stream))
     (when (eq ,streamvar 't)
       (setq ,streamvar *standard-input*))
     (unless (null ,streamvar)
       (let ((*CURFILE* nil)
             (*CURLINE* "")
             (*FNR* -1))
         (macrolet ((next () (list 'throw ',nextlbl nil)))
           (prog ,(if (eq linevar '*CURLINE*) nil (list linevar))
             ,nextlbl
                 (setq ,linevar (read-line ,streamvar nil :eof))
                 (unless (eq ,linevar :eof)
                    (setq *CURLINE* ,linevar
                          $0 ,linevar)
                    (incf *NR*)
                    (incf *FNR*)
                    (catch ',nextlbl
                      ,@body)
                    (go ,nextlbl))))))))



;;;
;;; FOR-FILE-LINES
;;;
;;; Iterate the body over the lines of the file.  Don't split the
;;; lines, but keep the current line in both *CURLINE* and $0.
;;;
;;; Need to do this with prog or labels, and macrolet (next) to jump to
;;; the read-next-line logic.
;;;
(defmacro for-file-lines ((path &optional (streamvar (gensym))
                                          (linevar (gensym)))
                                &rest body)
  #+symbolics (declare (zwei:indentation 1 1))
  (expand-for-file-lines streamvar linevar path body))
#+:Lispworks (editor:setup-indent "for-file-lines" 1 2 6)

(defun expand-for-file-lines (streamvar linevar path body)
  `(with-open-file (,streamvar ,path
                             :direction :input
                             :element-type 'character
                             :if-does-not-exist :error)
     ,(expand-for-stream-lines streamvar linevar streamvar body)))


;;;
;;; FOR-STREAM-FIELDS
;;;
;;; Iterate the body over the lines of the stream.  Split the lines
;;; based on *FS*.  Depending on what fieldspec you provide, the
;;; various $n vars may or may not be set (except for $0, which is the
;;; current line).
;;;
;;; As a special case, the value 't will use *standard-input* as the stream.
;;;
(defmacro for-stream-fields ((stream &optional fieldspec
                                              (strmvar (gensym))
                                              (linevar (gensym)))
                                     &rest body)
  #+Symbolics (declare (zwei:indentation 1 1))
  (expand-for-stream-fields strmvar linevar fieldspec stream body))
#+:Lispworks (editor:setup-indent "for-stream-fields" 1 2 6)

(defun expand-for-stream-fields (strmvar linevar fieldspec stream body
                                         &key (curfile-name stream curfile-name-p)
                                         &aux (nextlbl (gensym)))
  `(let ((,strmvar ,stream))
     (if (eq ,strmvar 't)
         (setq ,strmvar *standard-input*))
     (unless (null ,strmvar)
       (let (,@(if curfile-name-p `((*CURFILE* ,curfile-name)))
             (*CURLINE* "")
             (*FNR* -1))
         (macrolet ((next () (list 'throw ',nextlbl nil)))
           (prog ,(if (eq linevar '*CURLINE*) nil (list linevar))
             ,nextlbl
                 (setq ,linevar (read-line ,strmvar nil :eof))
                 (unless (eq ,linevar :eof)
                    (setq *CURLINE* ,linevar
                          $0 ,linevar)
                    (incf *NR*)
                    (incf *FNR*)
                    (catch ',nextlbl
                      ,(expand-with-fields fieldspec linevar '*FS* body))
                    (go ,nextlbl))))))))



;;;
;;; FOR-FILE-FIELDS
;;;
;;; Open the filepath, then iterate the body over the lines.  Split the lines
;;; based on *FS*.  Depending on what fieldspec you provide, the various $n vars
;;; may or may not be set (except for $0, which is the current line).
;;;
(defmacro for-file-fields ((path &optional fieldspec
                                          (strmvar (gensym))
                                          (linevar (gensym)))
                                 &rest body)
  #+Symbolics (declare (zwei:indentation 1 1))
  (expand-for-file-fields strmvar linevar fieldspec path body))
#+:Lispworks (editor:setup-indent "for-file-fields" 1 2 6)

(defun expand-for-file-fields (strmvar linevar fieldspec path body)
  `(with-open-file (,strmvar ,path
                             :direction :input
                             :element-type 'character
                             :if-does-not-exist :error)
     ,(expand-for-stream-fields strmvar linevar fieldspec strmvar body :curfile-name path)))




;;;
;;; WHEN-STREAM-FIELDS
;;;
;;; Guts of AWK toplevel for a file, but unlike AWK this can be
;;; used anywhere.
;;;
(defmacro when-stream-fields ((stream &optional fieldspec) &rest clauses)
  #+Symbolics (declare (zwei:indentation 1 1))
  (let ((docs-and-decs (extract-docs-and-decs clauses))
        (begin-clauses (extract-begin-clauses clauses))
        (end-clauses (extract-end-clauses clauses))
        (pattern-clauses (extract-pattern-clauses clauses)))
    `(locally ,@docs-and-decs
              (progn ,@(mapcan #'rest begin-clauses)
                     (for-stream-fields (,stream ,fieldspec)
                       ,@(mapcar #'expand-match-when-clause pattern-clauses))
                     ,@(mapcan #'rest end-clauses)))))
#+:Lispworks (editor:setup-indent "when-stream-fields" 1 2 6)

(defmacro when-file-fields ((path &optional fieldspec) &rest clauses)
  #+Symbolics (declare (zwei:indentation 1 1))
  (let ((docs-and-decs (extract-docs-and-decs clauses))
        (begin-clauses (extract-begin-clauses clauses))
        (end-clauses (extract-end-clauses clauses))
        (pattern-clauses (extract-pattern-clauses clauses)))
    `(locally ,@docs-and-decs
              (progn ,@(mapcan #'rest begin-clauses)
                     (for-file-fields (,path ,fieldspec)
                       ,@(mapcar #'expand-match-when-clause pattern-clauses))
                     ,@(mapcan #'rest end-clauses)))))
#+:Lispworks (editor:setup-indent "when-file-fields" 1 2 6)



;;;
;;; Fakes a reasonably close equivalent to a top-level awk program.
;;;
;;;
;;; This needs to be modified to run the BEGIN clauses *ONCE* before
;;; any files are processed, and similarly run the END clauses once
;;; after the files are processed.
;;;

(defmacro defawk (name (&rest parms) &rest clauses)
  (let ((file-or-stream (gensym))
        (process-stream-fn (gensym))
        (strm (gensym))
        (docs-and-decs (extract-docs-and-decs clauses))
        (begin-clauses (extract-begin-clauses clauses))
        (end-clauses (extract-end-clauses clauses))
        (pattern-clauses (extract-pattern-clauses clauses)))
    `(defun ,name (&rest ARGS ,@parms ,@(if (member '&key parms) '((&allow-other-keys))))
       ;; docstrings and declarations
       ,@docs-and-decs
       ;; shadow our globals with their good values
       (let ((*CURFILE*) (*CURLINE* "")
             (*FS* "[ \\t]+")
             (*RSTART* 0) (*RLENGTH* 0) (*REND* 0)
             (*REGS* (make-array 0))
             (*FIELDS* (make-array 0))
             (*NR* 0) (*FNR* 0) (*NF* 0)
             (*SUBSEP* (string (code-char #o34)))
             (*OFS* " ") (*ORS* "\n")
             (*LAST-SUCCESSFUL-MATCH*))
         (declare (special *CURFILE* *CURLINE* *FS* *RSTART* *RLENGTH*
                           *REND* *REGS* *FIELDS* *NR* *FNR* *NF*
                           *SUBSEP* *OFS* *ORS* *LAST-SUCCESSFUL-MATCH*))
         (flet ((,process-stream-fn (,strm)
                                    ,(expand-for-stream-fields strm '*CURLINE* nil strm
                                                               (mapcar
                                                                #'expand-match-when-clause
                                                                pattern-clauses))))
           ;; run BEGIN clauses
           ,@(mapcan #'rest begin-clauses)
           ;; process files
           (dolist (,file-or-stream ARGS)
             (cond ((eq ,file-or-stream 't)
                    (,process-stream-fn *standard-input*))
                   ((and (streamp ,file-or-stream) (input-stream-p ,file-or-stream))
                    (,process-stream-fn ,file-or-stream))
                   ((or (pathnamep ,file-or-stream) (stringp ,file-or-stream))
                    (let ((*CURFILE* ,file-or-stream))
                      (declare (special *CURFILE*))
                      (with-open-file (,strm ,file-or-stream
                                             :direction :input
                                             :element-type 'character
                                             :if-does-not-exist :error)
                        (,process-stream-fn ,strm))))))
           ;; run END clauses
           ,@(mapcan #'rest end-clauses))))))



;;;
;;; misc generic functions
;;;
(defun $+ (&rest rest)
  (reduce #'+ (mapcar #'num rest)))
(defun $- (&rest rest)
  (reduce #'- (mapcar #'num rest)))
(defun $* (&rest rest)
  (reduce #'* (mapcar #'num rest)))
(defun $/ (&rest rest)
  (reduce #'/ (mapcar #'num rest)))
(defun $rem (x y)
  (rem (num x) (num y)))
(defun $exp (y)
  ($exp (num y)))
(defun $expt (x y)
  (expt (num x) (num y)))
(defun $atan2 (x y)
  (atan (num x) (num y))) 
(defun $cos (x)
  (cos (num x)))
(defun $sin (x)
  (sin (num x)))
(defun $int (x)
  (truncate (num x)))
(defun $log (x)
  (log (num x)))
(defun $sqrt (x)
  (sqrt (num x)))
(defun $rand ()
  (random 1.0))

(defvar *random-states* (make-hash-table))

(defun $srand (x)
  (let ((nx (num x)))
    (let ((oldstate (gethash nx *random-states*)))
      (if oldstate
          (setq *random-state* oldstate)
        (setf *random-state* (make-random-state)
              (gethash nx *random-states*) *random-state*)))))

(defun $++ (&rest rest)
  (reduce #'(lambda (x y) (concatenate 'string x (str y)))
          (mapcar #'str rest)))

(defgeneric ! (x))
(defmethod ! ((x number))
  (zerop x))
(defmethod ! ((x (eql nil)))
  1)
(defmethod ! ((x string))
  (zerop (num x)))

(defgeneric $== (x y))
(defmethod $== (x y)
  (= (num x) (num y)))
(defmethod $== ((x number) (y number))
  (= x y))
(defmethod $== ((x number) (y string))
  (= x (num y)))
(defmethod $== ((x string) (y number))
  (= (num x) y))
(defmethod $== ((x string) (y string))
  (string= x y))

(defgeneric $< (x y))
(defmethod $< (x y)
  (< (num x) (num y)))
(defmethod $< ((x number) (y number))
  (< x y))
(defmethod $< ((x number) (y string))
  (< x (num y)))
(defmethod $< ((x string) (y number))
  (< (num x) y))
(defmethod $< ((x string) (y string))
  (string< x y))

(defgeneric $> (x y))
(defmethod $> (x y)
  (> (num x) (num y)))
(defmethod $> ((x number) (y number))
  (> x y))
(defmethod $> ((x number) (y string))
  (> x (num y)))
(defmethod $> ((x string) (y number))
  (> (num x) y))
(defmethod $> ((x string) (y string))
  (string> x y))

(defgeneric $<= (x y))
(defmethod $<= (x y)
  (<= (num x) (num y)))
(defmethod $<= ((x number) (y number))
  (<= x y))
(defmethod $<= ((x number) (y string))
  (<= x (num y)))
(defmethod $<= ((x string) (y number))
  (<= (num x) y))
(defmethod $<= ((x string) (y string))
  (string<= x y))

(defgeneric $>= (x y))
(defmethod $>= (x y)
  (>= (num x) (num y)))
(defmethod $>= ((x number) (y number))
  (>= x y))
(defmethod $>= ((x number) (y string))
  (>= x (num y)))
(defmethod $>= ((x string) (y number))
  (>= (num x) y))
(defmethod $>= ((x string) (y string))
  (string>= x y))

(defgeneric $/= (x y))
(defmethod $/= (x y)
  (/= (num x) (num y)))
(defmethod $/= ((x number) (y number))
  (/= x y))
(defmethod $/= ((x number) (y string))
  (/= x (num y)))
(defmethod $/= ((x string) (y number))
  (/= (num x) y))
(defmethod $/= ((x string) (y string))
  (string/= x y))
(defun != (x y)
  ($/= x y))


(defgeneric $max (x &rest rest))
(defmethod $max (x &rest rest)
  (reduce #'max (mapcar #'num rest) :initial-value (num x)))
(defmethod $max ((x number) &rest rest)
  (reduce #'max (mapcar #'num rest) :initial-value x))
(defmethod $max ((x string) &rest rest)
  (reduce #'max (mapcar #'str rest) :initial-value x))
                 
(defgeneric $min (x &rest rest))
(defmethod $min (x &rest rest)
  (reduce #'min (mapcar #'num rest) :initial-value (num x)))
(defmethod $min ((x number) &rest rest)
  (reduce #'min (mapcar #'num rest) :initial-value x))
(defmethod $min ((x string) &rest rest)
  (reduce #'min (mapcar #'str rest) :initial-value x))

(defgeneric $zerop (x))
(defmethod $zerop (x)
  (declare (ignore x))
  nil)
(defmethod $zerop ((x number))
  (zerop x))
(defmethod $zerop ((x (eql nil)))
  t)
(defmethod $zerop ((x string))
  (not (null (or (string= x "") (string= x "0") (string= x "0.0")))))

(defgeneric $length (x))
(defmethod $length (x)
  (length x))
(defmethod $length ((x number))
  (length (str x)))
(defmethod $length ((x (eql nil)))
  0)

(defun $print (&rest rest)
  (do-$fprint *standard-output* rest))
(defun $fprint (stream &rest rest)
  (do-$fprint stream rest))
(defun do-$fprint (stream lst)
  (if (string= *ORS* "\n")
      (format stream "~%")
    (format stream "~A" *ORS*))
  (loop for item in lst
        do (format stream "~A~A" (str item) *OFS*)))




;;;
;;; Awk-like associative arrays (built on hashtable, obviously)
;;;
(defun $array ()
  (make-hash-table :test 'equalp))


;; AWK associative-arrays have the odd characteristic that simply
;; checking for the presence of a key adds it to the array.
(defun assoc-array-ref (tbl index)
  (multiple-value-bind (val foundp)
      (gethash index tbl)
    (if foundp
	val
	(setf (gethash index tbl) ""))))

(defsetf assoc-array-ref (tbl index) (val)
  `(setf (gethash ,index ,tbl) ,val))

(defmacro $aref (tbl index &rest other-indices)
  (if (null other-indices)
      `(assoc-array-ref ,tbl (str ,index))
    `(assoc-array-ref ,tbl
		      (concatenate
			'string
			(str ,index)
			,@(mapcan #'(lambda (x)
				      `(*SUBSEP* (str ,x)))
				  other-indices)))))

; equivalent to:  for (x in a) ...
(defmacro $for ((keyvar in tbl) &rest body)
  (declare (ignore in))
  #+Symbolics (declare (zwei:indentation 1 1))
  `(loop for ,keyvar being the hash-keys of ,tbl
         do (progn ,@body)))
#+:Lispworks (editor:setup-indent "$for" 1 2 6)

; equivalent to: x in a
(defun $in (key tbl)
  (multiple-value-bind (val presentp)
      (getf key tbl)
    (declare (ignore val))
    presentp))

; equivalent to either delete a[i] or delete a
(defun $delete (tbl &optional (elt nil eltp))
  (if eltp
      (remhash elt tbl)
    (clrhash tbl)))

; return the cardinality of the table
(defmethod $length ((x hash-table))
  (hash-table-count x))