Commit b01240c9 by Francois-Rene Rideau

Moved reader-interception out of fare-utils.

parents
READER-INTERCEPTION
This library allows you to intercept the Lisp reader
and replace the Lisp syntax with your own.
Applications include:
* using COMPILE-FILE to compile files in arbitrary languages,
by having a reader that expands the language into Lisp code.
* having your own improved syntax replace the CL syntax
while using the CL runtime.
==== Exported Functionality ====
The reader-interception library creates a package READER-INTERCEPTION,
that exports the following macros and functions:
WITH-READER-INTERCEPTION ((HINT READER) &BODY BODY)
This macro allows you to intercept the reader within its BODY.
READER is a function that has the same interface as #'CL:READ.
You must pass a HINT, which must be one of:
* the pathname of the file that will be read
* the stream that will be read
* the string that will be read from
* the first character of the file, stream or string that will be read from.
* T if you don't know or care which character that will be, but
can promise it will be ASCII (char-code strictly less than 128).
* NIL if you promise that whichever character will be next read (if any)
has already been seen by the reader-interception
(notably works on empty files/streams/strings).
#+xcvb
(module
(:fullname "reader-interception"
:depends-on ("reader-interception")
:supersedes-asdf ("reader-interception")))
;;; -*- Mode: Lisp ; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
(asdf:defsystem :reader-interception-test
:depends-on (:reader-interception :fare-utils :hu.dwim.stefil)
:components
((:file "reader-interception-test")))
#+xcvb (module (:depends-on ("reader-interception" (:asdf "hu.dwim.stefil"))))
(defpackage :reader-interception-test
(:use :cl :fare-utils :reader-interception :hu.dwim.stefil))
(in-package :reader-interception-test)
(declaim (optimize (speed 1) (debug 3) (space 3)))
;;; Testing the reader-interception library.
;;; We use a reader for a trivial infix mini-language defined below.
;;; First, test the below parser directly, without reader interception.
;;; Second, test the parser through reader interception.
(defsuite* (test-suite
:in root-suite
:documentation "Testing reader interception"))
(defun string-parse-sum (string)
(with-input-from-string (s string)
(parse-sum s)))
(defun string-parse-sum-via-read (x)
(with-input-from-string (s x)
(with-reader-interception (s 'parse-sum) ;; we could use either s or x as the hint
(read s))))
(defvar *infix-expressions*
'(("42" . 42)
("1+(2*3)/4*(5-6*7)+-8+9" .
(+ 1 (* (identity (* 2 3)) (/ 4) (identity (- 5 (* 6 7)))) (- 8) 9))
("a*a+2*a*b+b*b" .
(+ (* a a) (* 2 a b) (* b b)))
("(-b+deltaroot)/2/a" .
(/ (identity (+ (- b) deltaroot)) 2 a))
("b*b-4*a*c" .
(- (* b b) (* 4 a c)))))
(defun test-parser (parser)
(loop :for (string . sexp) :in *infix-expressions* :do
(eval `(is (equal (,parser ,string) ',sexp)))))
(deftest test-parse-sum ()
(test-parser 'string-parse-sum))
(deftest test-intercepted-read ()
(test-parser 'string-parse-sum-via-read))
;;; Here is our trivial recursive-decent parser, for arithmetic expressions
;;; using +-*/, ()[]{}, integers and identifiers made of
;;; alphanumeric characters starting with an alphabetic one.
;;; Space doesn't count between other tokens.
;;; End of stream, punctuation ;.,!? or ending parentheses \]}
;;; properly terminate an expression.
;;; Other characters are an error.
;;; The result read is a SEXP corresponding to your expression,
;;; Using + - * / identity
;;; Multiple sum terms are collected in a single sum SEXP,
;;; with a slight simplification for differences:
;;; we don't distinguish a-b and a+-b.
;;; Identifiers are upcased as symbols in your current package.
(defun oppositep (x)
(single-arg-form-p '- x))
(defun inversep (x)
(single-arg-form-p '/ x))
(defun spacep (x)
(find x #.(coerce #(#\space #\tab #\return #\linefeed) 'string)))
(defvar *char-read-count* 0)
(defun read-count-char (stream &optional eof-error-p)
(let ((char (read-char stream eof-error-p nil t)))
(when char (incf *char-read-count*))
char))
(defun undo-read-char (char stream)
(when char
(unread-char char stream)
(decf *char-read-count*))
nil)
(defun terminatorp (char)
(and (position char #(nil #\) #\] #\} #\; #\. #\, #\! #\?)) t))
(defun parse-infix-sum (stream)
(let ((*count* 0))
(values (parse-sum stream) *count*)))
(defun next-term-char (stream &key eof-error-p)
(loop :for char = (read-count-char stream eof-error-p)
:for spacep = (and char (spacep char))
:while spacep :finally
(return (or (and char (not spacep) char)
(undo-read-char char stream)))))
(defun open-paren-p (char)
(find char "([{"))
(defun paren-closer (char)
(char ")]}" (position char "([{")))
(defun parse-sum (stream)
(parse-sum-continuation
stream (list (parse-product stream))))
(defun sum-results (rterms)
(let ((terms (reverse rterms)))
(cond
((null (rest terms))
(first terms))
((every 'oppositep (rest terms))
`(- ,(first terms) ,@(mapcar 'second (rest terms))))
(t
`(+ ,@terms)))))
(defun parse-sum-continuation (stream rterms)
(let ((char (next-term-char stream :eof-error-p nil)))
(cond
((terminatorp char)
(undo-read-char char stream)
(sum-results rterms))
((eql char #\+)
(parse-sum-continuation
stream (cons (parse-product stream) rterms)))
((eql char #\-)
(parse-sum-continuation
stream (cons (list '- (parse-product stream)) rterms)))
(t
(undo-read-char char stream)
(error "Invalid character ~S after ~S" char (sum-results rterms))))))
(defun parse-product (stream)
(parse-product-continuation
stream (list (parse-terminal stream))))
(defun product-results (rfactors)
(let ((factors (reverse rfactors)))
(cond
((null (rest factors))
(first factors))
((every 'inversep (rest factors))
`(/ ,(first factors) ,@(mapcar 'second (rest factors))))
(t
`(* ,@factors)))))
(defun parse-product-continuation (stream rfactors)
(let ((char (next-term-char stream :eof-error-p nil)))
(cond
((or (terminatorp char) (find char "+-"))
(undo-read-char char stream)
(product-results rfactors))
((eql char #\*)
(parse-product-continuation
stream (cons (parse-terminal stream) rfactors)))
((eql char #\/)
(parse-product-continuation
stream (cons (list '/ (parse-terminal stream)) rfactors)))
(t
(undo-read-char char stream)
(error "Invalid character ~S after ~S" char (product-results rfactors))))))
(defun parse-terminal (stream)
(let ((char (next-term-char stream :eof-error-p t)))
(cond
((open-paren-p char)
(parse-paren char stream))
((find char "+-")
(list (find-symbol (string char) :cl)
(parse-terminal stream)))
((digit-char-p char)
(undo-read-char char stream)
(parse-decimal stream))
((alpha-char-p char)
(undo-read-char char stream)
(parse-identifier stream))
(t
(undo-read-char char stream)
(error 'reader-error :stream stream)))))
(defun parse-decimal (stream)
;; assume the first is already read then unread and a digit
(loop :with sum = 0
:for char = (read-count-char stream nil)
:for value = (and char (digit-char-p char))
:while value :do (setf sum (+ (* 10 sum) value))
:finally
(undo-read-char char stream)
(return sum)))
(defun parse-identifier (stream)
;; assume the first is already read then unread and alphabetical
(loop :for char = (read-count-char stream nil)
:while (and char (alphanumericp char)) :collect char :into chars
:finally
(undo-read-char char stream)
(return (intern (string-upcase (coerce chars 'string))))))
(defun parse-paren (paren stream)
(let ((sum (parse-sum stream))
(char (read-count-char stream t)))
(unless (eql char (paren-closer paren))
(error "unmatched paren ~S after ~S" paren sum))
(list 'identity sum)))
;;; -*- Mode: Lisp ; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
(defsystem :reader-interception
:description "Intercept the reader to replace CL syntax with your own"
:components
((:file "reader-interception")))
(defmethod perform ((op test-op) (system (eql (find-system :reader-interception))))
(asdf:load-system :reader-interception-test)
(funcall (asdf::find-symbol* :test-suite :reader-interception-test)))
(in-package :cl-user)
(defpackage :reader-interception
(:use :cl)
(:export
#:with-reader-interception
#:prepare-reader-interception))
(in-package :reader-interception)
(defmacro with-reader-interception ((hint reader) &body body)
"You may override the Common Lisp reader, e.g. around LOAD or COMPILE-FILE,
by using WITH-READER-INTERCEPTION (HINT READER) BODY...
thus replacing the CL syntax with any syntax of your choice.
By combining this with ASDF 2.018's :around-compile hook,
you could compile any language with CL via a proper translation frontend.
You *must* specify a HINT to pass to PREPARE-READER-INTERCEPTION,
to help the interception find the first (next) character that will be read,
so it can intercept reading from there.
You must specify your READER, a function taking a STREAM as argument,
and either returning an object or raising an error
such as READER-ERROR or END-OF-FILE.
Inside the BODY, the *READTABLE* is set so that you may READ
from a stream starting with the hinted character, and
it will use your specified parser instead of the CL reader.
Inside the READER itself, READ will behave like the unintercepted CL reader."
`(call-with-reader-interception (lambda () ,@body) ,hint ,reader))
(defun prepare-reader-interception (hint &key (external-format :default))
"Before you may intercept the CL reader, you MUST prime
the reader-interception with the first character to be read.
You may give the character itself,
NIL for no character (e.g. EOF),
T for any ASCII characters (assuming the first one won't be further unicode),
a stream to read the character from,
a string that will be used as input stream,
a pathname to be open as a stream to read from with specified external-format"
(etypecase hint
(null
nil)
((eql t)
(prepare-all-ascii))
(character
(prepare-character hint))
(string
(when (plusp (length hint))
(prepare-character (aref hint 0))))
(pathname
(with-open-file (s hint :direction :input
:if-does-not-exist :error
:element-type 'character
:external-format external-format)
(prepare-reader-interception s)))
(stream
(let ((next (read-char hint nil nil)))
(when next
(unread-char next hint)
(prepare-character next)))))
(values))
(defvar *saved-readtable* *readtable*)
(defvar *reader* 'standard-read)
(defvar *interception-readtable* (copy-readtable nil))
(defvar *intercepted-characters* (make-hash-table :test 'equal))
(defun initialize-interception ()
(setf *interception-readtable* (copy-readtable nil))
(setf *intercepted-characters* (make-hash-table :test 'equal)))
(defvar *standard-readtable* (copy-readtable nil))
(defun standard-read (&key
(stream *standard-input*)
(eof-error-p t) (eof-value nil)
(recursive-p nil))
(let ((*readtable* *standard-readtable*))
(with-standard-io-syntax
(read-preserving-whitespace
stream eof-error-p eof-value recursive-p))))
(defun prepare-character (x)
(unless (gethash x *intercepted-characters*)
(setf (gethash x *intercepted-characters*) t)
(set-macro-character x 'intercept-char-reader nil
*interception-readtable*)))
(defun intercept-char-reader (stream char)
(unread-char char stream)
(prog1 (let ((*readtable* *saved-readtable*))
(funcall *reader* stream))
(prepare-reader-interception stream)))
(defun prepare-all-ascii ()
;; assumes code-char uses ASCII for codepoints below 128
(loop :for c :below 128 :do
(prepare-character (code-char c))))
(defun call-with-reader-interception (thunk &optional hint (reader *reader*))
(prepare-reader-interception hint)
(let ((*reader* reader)
(*saved-readtable* *readtable*)
(*readtable* *interception-readtable*))
(funcall thunk)))
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment