diff options
| -rw-r--r-- | input.lisp | 46 | ||||
| -rw-r--r-- | package.lisp | 19 | ||||
| -rw-r--r-- | parser.lisp | 78 |
3 files changed, 88 insertions, 55 deletions
@@ -1,43 +1,43 @@ (in-package #:input) -(defstruct input - (cursor 0) - (file nil :read-only t) - (data nil :read-only t)) +(defclass input () + ((cursor :initarg :cursor :accessor cursor :initform 0) + (file :initarg :file :reader file :initform nil) + (data :initarg :data :reader data :initform nil))) -(defun has-data? (input &optional (window-size 1)) - (<= (+ window-size (input-cursor input)) - (length (input-data input)))) +(defun has-data? (input) + (< (cursor input) (length (data input)))) (defun prefix? (target input) - (string= target (input-data input) :start2 (input-cursor input) :end2 (+ (input-cursor input) (length target)))) + (string= target + (data input) + :start2 (cursor input) + :end2 (min (+ (cursor input) (length target)) + (length (data input))))) (defun peek (input) - (char (input-data input) - (input-cursor input))) + (char (data input) + (cursor input))) (defun advance (input &optional (amount 1)) - (let ((new-input (copy-structure input))) - (incf (input-cursor new-input) amount) - new-input)) + (make-instance 'input + :data (data input) + :file (file input) + :cursor (1+ (cursor input)))) -(declaim (ftype (function (simple-string) (values input &optional)) from-string)) (defun from-string (str) - (make-input :data str)) + (make-instance 'input :data str)) -(declaim (ftype (function (simple-string) (values input &optional)) from-file)) (defun from-file (filename) - (make-input :file filename :data (str:read-file filename))) + (make-instance 'input :file filename :data (str:read-file filename))) -(defun generate-report (input message) +(defun line-and-column (input) (let ((line 1) (column 1)) - (dotimes (i (input-cursor input)) - (let ((c (char (input-data input) i))) + (dotimes (i (cursor input)) + (let ((c (char (data input) i))) (case c (#\Newline (incf line) (setf column 1)) (t (incf column))))) - (if (input-file input) - (format nil "~a:~a:~a: ~a" (input-file input) line column message) - (format nil "~a:~a: ~a" line column message)))) + (values line column))) diff --git a/package.lisp b/package.lisp index 6e868f9..5936a52 100644 --- a/package.lisp +++ b/package.lisp @@ -1,11 +1,23 @@ (defpackage #:input (:use #:cl) - (:export #:from-string + (:export #:file + #:data + #:cursor + #:line-and-column + #:has-data? + #:prefix? + #:peek + #:advance + #:from-string #:from-file)) (defpackage #:parser (:use #:cl) - (:export #:run + (:export #:parsing-p + #:parsing-tree + #:parsing-left + #:failure-place + #:failure-message #:fail #:comp #:one-of @@ -19,5 +31,4 @@ #:nothing #:optional #:many - #:separated-list - #:whitespace)) + #:separated-list)) diff --git a/parser.lisp b/parser.lisp index c07120d..a48f6e3 100644 --- a/parser.lisp +++ b/parser.lisp @@ -1,19 +1,25 @@ (in-package #:parser) -(defun run (p input) - (let ((r (funcall p input))) - (if (parsing-p r) - (parsing-tree r) - (input::generate-report (failure-place r) (failure-message r))))) - (defstruct parsing tree left) +(defmethod print-object ((obj parsing) stream) + (print-unreadable-object (obj stream :type t) + (format stream "~a" (parsing-tree obj)))) + (defstruct failure place message) +(defmethod print-object ((obj failure) stream) + (print-unreadable-object (obj stream :type t) + (let ((file (input:file (failure-place obj)))) + (if file + (multiple-value-bind (line column) (input:line-and-column (failure-place obj)) + (format stream "~a:~a:~a: ~a" line column file (failure-message obj))) + (format stream "~a: ~a" (input:cursor (failure-place obj)) (failure-message obj)))))) + (defstruct (normal-failure (:include failure))) (defstruct (critical-failure (:include failure))) @@ -22,18 +28,34 @@ (lambda (input) (make-parsing :tree tree :left input))) +(defun bind-with-input (p f) + (declare (optimize (speed 3))) + (declare (type function p f)) + (lambda (input) + (let ((r (funcall p input))) + (if (parsing-p r) + (funcall (the function (funcall f (parsing-tree r) input)) + (parsing-left r)) + r)))) + (defun bind (p f) + (declare (optimize (speed 3))) + (declare (type function p f)) (lambda (input) (let ((r (funcall p input))) (if (parsing-p r) - (funcall (funcall f (parsing-tree r)) (parsing-left r)) + (funcall (the function (funcall f (parsing-tree r))) + (parsing-left r)) r)))) (defun discarding-bind (p f) + (declare (optimize (speed 3))) + (declare (type function p f)) (lambda (input) (let ((r (funcall p input))) (if (parsing-p r) - (funcall (funcall f) (parsing-left r)) + (funcall (the function (funcall f)) + (parsing-left r)) r)))) (defmacro comp (bindings &body body) @@ -41,9 +63,15 @@ `(new (progn ,@body)) (let ((v (first (car bindings))) (p (second (car bindings)))) - (if (string= (symbol-name v) "_") - `(discarding-bind ,p (lambda () (comp ,(cdr bindings) ,@body))) - `(bind ,p (lambda (,v) (comp ,(cdr bindings) ,@body))))))) + (if (eq 'symbol (type-of v)) + (if (string= (symbol-name v) "_") + `(discarding-bind ,p (lambda () (comp ,(cdr bindings) ,@body))) + `(bind ,p (lambda (,v) (comp ,(cdr bindings) ,@body)))) + (if (and (eq 'cons (type-of v)) + (eq 'symbol (type-of (car v))) + (eq 'symbol (type-of (cdr v)))) + `(bind-with-input ,p (lambda (,(car v) ,(cdr v)) (comp ,(cdr bindings) ,@body))) + (error "Binding name/(name,input) must be either a symbol or a cons of symbols.")))))) (defun fail (&optional (message "Unknown error.")) (lambda (input) @@ -82,10 +110,10 @@ (defun unit-if (&optional (predicate #'characterp)) (lambda (input) - (if (input::has-data? input) - (let ((c (input::peek input))) + (if (input:has-data? input) + (let ((c (input:peek input))) (if (funcall predicate c) - (make-parsing :tree c :left (input::advance input)) + (make-parsing :tree c :left (input:advance input)) (make-normal-failure :place input :message "Predicate not satisfied."))) (make-normal-failure :place input :message "Reached end of input.")))) @@ -97,21 +125,19 @@ (defun literal (target) (lambda (input) - (if (input::has-data? input (length target)) - (if (input::prefix? target input) - (make-parsing :tree target :left (input::advance input (length target))) + (if (input:has-data? input) + (if (input:prefix? target input) + (make-parsing :tree target :left (input:advance input (length target))) (make-normal-failure :place input :message "Predicate not satisfied.")) - (make-normal-failure :place input :message "Not enough data.")))) + (make-normal-failure :place input :message "Reached end of input.")))) (defun not-literal (target) (lambda (input) - (if (input::has-data? input (length target)) - (if (input::prefix? target input) + (if (input:has-data? input) + (if (input:prefix? target input) (make-normal-failure :place input :message "Predicate not satisfied.") - (make-parsing :tree (input::peek input) :left (input::advance input))) - (if (input::has-data? input) - (make-parsing :tree (input::peek input) :left (input::advance input)) - (make-normal-failure :place input :message "Reached end of input."))))) + (make-parsing :tree (input:peek input) :left (input:advance input))) + (make-normal-failure :place input :message "Reached end of input.")))) (defparameter nothing (new nil)) @@ -134,7 +160,3 @@ (if include-separator (cons v (cons sep vn)) (cons v vn)))) - -(defparameter whitespace - (comp ((_ (optional (many (unit-if (lambda (x) (or (char= x #\Space) (char= x #\Newline) (char= x #\Tab)))))))) - nil)) |