Number Input Reader
Okay... here is a cleaned up version, tried and tested on its own from a fresh restart of the Lisp system. I also did find the answer to repetition indications in patterns and made those improvements as well...Here's everything you need...
;; -----------------------------------------------------------
;; tools needed to support Doug Hoyte's DEFMACRO!
(eval-when (:compile-toplevel :load-toplevel :execute)
(defmacro perform (name bindings &body body)
(let ((args (mapcar #'first bindings))
(vals (mapcar #'second bindings)))
`(labels ((,name ,args ,@body))
(,name ,@vals))
))
(defmacro nlet (name bindings &body body)
;; NLET = Named LET
`(perform ,name ,bindings ,@body))
(defun flatten (x)
(nlet rec ((x x)
(acc nil))
(cond ((null x) acc)
((atom x) (cons x acc))
(t (rec (car x) (rec (cdr x) acc))))
))
;; in ML these are referred to as sections
;; these actually correspond to the Dylan operators
;; secr ::= rcurry, secl ::= curry
(defun curry (fn &rest pref-args)
(lambda (&rest suf-args)
(apply fn (append pref-args suf-args))))
(defun rcurry (fn &rest suf-args)
(lambda (&rest pref-args)
(apply fn (append pref-args suf-args))))
(defun collect-if (predicate proseq &rest rest)
(apply 'remove-if-not predicate proseq rest))
;; --------------------------------------------
;; Bang-symbols
(defun bang-symbol-p (prefix s)
(and (symbolp s)
(> (length (symbol-name s)) 2)
(string= (symbol-name s) prefix
:start1 0
:end1 2)))
(defun get-bang-symbols (prefix body)
(remove-duplicates
(collect-if (curry #'bang-symbol-p prefix) (flatten body))))
(defun bang-symbol-name (s)
(subseq (symbol-name s) 2))
;; --------------------------------------------
(defun raw-mkstr (&rest args)
(with-output-to-string (s)
(dolist (a args)
(princ a s))
))
(defun mkstr (&rest args)
(with-standard-io-syntax
(apply #'raw-mkstr args)))
(defun correct-for-symbol-character-case (str)
;; a portable way to make symbol strings
;; Modern Mode vs ANSI
(if (eql #\a (char (string :a) 0))
(string-downcase (string str))
(string-upcase (string str))))
(defun intern-symbol (str &rest package)
(apply #'intern (correct-for-symbol-character-case str) package))
(defun symb (&rest args)
(values (intern-symbol (apply #'mkstr args))))
;; --------------------------------------------
(defun |reader-for-#`| (stream sub-char numarg)
(declare (ignore sub-char))
(unless numarg (setq numarg 1))
`(lambda ,(loop for i from 1 to numarg
collect (symb 'a i))
,(funcall
(get-macro-character #\`) stream nil)))
) ;; end of eval-when #1
(set-dispatch-macro-character
#\# #\` #'|reader-for-#`|)
(eval-when (:compile-toplevel :load-toplevel :execute)
;; --------------------------------------------
;; A-Bang symbols -- create anaphoric symbol names
;; in package of macro expansion
(defmacro defmacro/a! (name args &body body)
(let ((syms (get-bang-symbols #.(symbol-name :A!) body)))
`(defmacro ,name ,args
(let ,(mapcar #`(,a1 (intern ,(bang-symbol-name a1))) syms)
,@body))))
;; --------------------------------------------
;; G-Bang symbols -- auto generated gensyms
(defmacro defmacro/g! (name args &body body)
(let ((syms (get-bang-symbols #.(symbol-name :G!) body)))
`(defmacro/a! ,name ,args
(let ,(mapcar #`(,a1 (gensym ,(bang-symbol-name a1))) syms)
,@body))))
;; --------------------------------------------
;; O-Bang symbols -- once-only eval gensyms
(defun o!-symbol-to-g!-symbol (s)
(symb #.(symbol-name :G!)
(bang-symbol-name s)))
(defmacro defmacro! (name args &body body)
(let* ((os (get-bang-symbols #.(symbol-name :O!) args))
(gs (mapcar #'o!-symbol-to-g!-symbol os)))
`(defmacro/g! ,name ,args
`(let ,(mapcar #'list (list ,@gs) (list ,@os))
,(progn
,@body)))
))
;; ---------------------------------------
;; This part from Doug Hoyte using Edi's ppcre
(defun segment-reader (stream ch n)
(if (> n 0)
(let ((chars))
(do ((curr (read-char stream)
(read-char stream)))
((char= ch curr))
(push curr chars))
(cons (coerce (nreverse chars) 'string)
(segment-reader stream ch (- n 1))))))
;; ---------------------------------------
#+cl-ppcre
(defmacro! match-mode-ppcre-lambda-form (o!args)
``(lambda (,',g!str)
(cl-ppcre:scan
,(car ,g!args)
,',g!str)))
#+cl-ppcre
(defmacro! subst-mode-ppcre-lambda-form (o!args)
``(lambda (,',g!str)
(cl-ppcre:regex-replace-all
,(car ,g!args)
,',g!str
,(cadr ,g!args))))
#+cl-ppcre
(defun |reader-for-#~| (stream sub-char numarg)
(declare (ignore sub-char numarg))
(let ((mode-char (read-char stream)))
(cond
((char= mode-char #\m)
(match-mode-ppcre-lambda-form
(segment-reader stream
(read-char stream)
1)))
((char= mode-char #\s)
(subst-mode-ppcre-lambda-form
(segment-reader stream
(read-char stream)
2)))
(t (error "Unknown #~~ mode character")))))
) ;; end of eval-when #2
#+cl-ppcre
(set-dispatch-macro-character #\# #\~ #'|reader-for-#~|)
(eval-when (:compile-toplevel :load-toplevel :execute)
;; --------------------------------------------------------------
;; Allow extended number syntax:
;; - embedded underscore separators 123_445.789_443
;; - allow 1+2j or 1-2j or just 2j, where j in [jJiI]
;; - allow dates in yyyy/mm/dd format
;; - allow sexigisimal time in |hh:mm:ss.ss| format (bars needed because of #\:)
;; - allow hyphenated numbers as in telephone numbers, SSN's, and UUID's
(defun remove-separators (s)
(delete #\, (delete #\_ s)))
(defun match-number (s)
(multiple-value-bind (start end)
(#~m/^[+-]?[0-9][0-9_,]*(\.[0-9_,]*([eEdD][+-]?[0-9]+)?)?/ s)
(when start
(values (read-from-string (remove-separators (subseq s start end)))
(subseq s end))
)))
(defun match-complex-ij (s)
(#~m/^[iIjJ]$/ s))
(defun convert-real-or-complex (s)
(multiple-value-bind (val srest)
(match-number s)
(when val
(cond ((= 0 (length srest)) val)
((match-complex-ij srest) (complex 0 val))
((multiple-value-bind (ival sresti)
(match-number srest)
(and ival
(match-complex-ij sresti)
(complex val ival))))
(t nil)))
))
(defun convert-sexigisimal (s)
;; hh:mm:ss.ss, or hh:mm
(multiple-value-bind (start end gstart gend)
(#~m/^([+-])?([0-9]+):([0-9]{1,2})(:[0-9]{1,2}(\.[0-9_,]*)?)?$/ s)
(declare (ignore end))
(when start
(symbol-macrolet
((sign (aref gstart 0))
(hstart (aref gstart 1))
(hend (aref gend 1))
(mstart (aref gstart 2))
(mend (aref gend 2))
(sstart (aref gstart 3))
(send (aref gend 3))
(sfrac (aref gstart 4)))
(ignore-errors
(let* ((hh (read-from-string (subseq s hstart hend)))
(mm (read-from-string (subseq s mstart mend)))
(ss (if sstart
(read-from-string (remove-separators
(subseq s (1+ sstart) send)))
0))
(val (+ (* 60 (+ (* 60 hh) mm))
(if sfrac
(float ss 1d0)
ss))))
(if (and sign
(char= (char s sign) #\-))
(- val)
val)
))))))
(defun convert-date (s)
;; yyyy/mm/dd
(multiple-value-bind (start end gstart gend)
(#~m%^([0-9]{4})/([0-9]{1,2})/([0-9]{1,2})$% s)
(declare (ignore end))
(when start
(symbol-macrolet
((ystart (aref gstart 0))
(yend (aref gend 0))
(mstart (aref gstart 1))
(mend (aref gend 1))
(dstart (aref gstart 2))
(dend (aref gend 2)))
(ignore-errors
(let* ((yyyy (read-from-string (subseq s ystart yend)))
(mm (read-from-string (subseq s mstart mend)))
(dd (read-from-string (subseq s dstart dend))))
(encode-universal-time 0 0 0 dd mm yyyy)
))))))
(defun convert-american-short-date (s)
;; mm/dd/yy
(multiple-value-bind (start end gstart gend)
(#~m%^([0-9]{1,2})/([0-9]{1,2})/([0-9]{1,2})$% s)
(declare (ignore end))
(when start
(symbol-macrolet
((ystart (aref gstart 2))
(yend (aref gend 2))
(mstart (aref gstart 0))
(mend (aref gend 0))
(dstart (aref gstart 1))
(dend (aref gend 1)))
(ignore-errors
(let* ((yyyy (+ 2000 (read-from-string (subseq s ystart yend))))
(mm (read-from-string (subseq s mstart mend)))
(dd (read-from-string (subseq s dstart dend))))
(encode-universal-time 0 0 0 dd mm yyyy)
))))))
(defun convert-hyphenated-number (s)
;; xxxx-xx-xxxx as in telephone numbers, SSN's, and UUID's
(if (#~m/^[0-9]+(\-[0-9]+)*$/ s)
(read-from-string (delete #\- s))))
(defun convert-other-base-number (s)
;; #xNNNN_NNNN_NNN
(when (or (#~m/^[xXoObB]/ s)
(#~m/^[0-9]+[rR]/ s))
(ignore-errors
(read-from-string (format nil "#~A" (remove-separators s))))))
(defun |reader-for-#n| (stream sub-char numarg)
(declare (ignore sub-char numarg))
(let ((v (read stream t nil t)))
(if (symbolp v)
(let ((s (symbol-name v)))
(cond ((convert-real-or-complex s))
((convert-sexigisimal s))
((convert-date s))
((convert-american-short-date s))
((convert-hyphenated-number s))
((convert-other-base-number s))
(t v)))
;; else -- not a symbol (!?)
v)))
) ;; end of eval-when #3
(set-dispatch-macro-character
#\# #\n #'|reader-for-#n|)
;; --------------------------------------
Dr. David McClain
Chief Technical Officer
Refined Audiometrics Laboratory
4391 N. Camino Ferreo
Tucson, AZ 85750
email: dbm@refined-audiometrics.com
phone: 1.520.390.3995