Changeset trunk,16 for trunk

Timestamp:

06/23/2007 06:11:55 AM (19 years ago)

Author:

dsowen

revision id:

svn-v3-trunk0:2948df59-2b31-0410-8e06-c40c0b09d5b6:trunk:16

Message:

Rearranging around the new macros.

Location:

trunk

Files:

• package.lisp (modified) (1 diff)
• parse.lisp (modified) (1 diff)

trunk/package.lisp

@@ -1 @@
-(defpackage #:parse
+(defpackage #:dso-parse
   (:documentation
    "Defines macros for matching input against rules and building trees

trunk/parse.lisp

@@ -1 @@
-(defpackage #:parse
-  (:use #:cl #:cl-ppcre)
-  (:export #:defgrammar
-           #:token))
-
-(in-package #:parse)
-
-
-
-(defstruct token
-  class
-  string)
-
-;;;; A parser returns, as a list, all parts matched; and, the
-;;;; remainder of the token-list.  Named parts appear as sub-trees.
-
-
-
-(defmacro with-gensyms (syms &body body)
-  `(let (,@(mapcar (lambda (sym) `(,sym (gensym ,(symbol-name sym)))) syms))
-    ,@body))
-
-(defun substring (string &key (start 0) end length)
-  (when (and end length) (error "Specify only one of END or LENGTH."))
-  (when end (setf length (- end start)))
-  (unless length (setf length (- (length string) start)))
-  (make-array length
-              :element-type 'character
-              :displaced-to string
-              :displaced-index-offset start))
-
-(defmacro scase (sym &body clauses)
-  (with-gensyms (sym-name)
-    `(let ((,sym-name (symbol-name ,sym)))
-      (cond
-        ,@(mapcar #'(lambda (clause)
-                      (if (eq t (first clause))
-                          clause
-                          (let ((clause-sym-name (symbol-name (first clause)))
-                                (clause-body (rest clause)))
-                            `((string= ,sym-name ,clause-sym-name)
-                              ,@clause-body))))
-                  clauses)))))
-
-(defmacro specials ((&body decls) &body body)
-  "Like LET, but declares the bound variables to be special."
-  `(let ,decls
-    (declare (special ,@(mapcar #'first decls)))
-    ,@body))
-
-(defun as-list (item) (if (listp item) item (list item)))
-
-
-
-
-
-;; This is the entry-point for now.
-
-(defun make-parser (rule)
-  (declare (ignore rule))
-  nil)
-
-
-
-(defun parse-sequence (rule-parsers token-list tree)
-  (if rule-parsers
-      (multiple-value-bind (matched rlist mtree)
-          (funcall (first rule-parsers) token-list)
-        (when matched
-          (parse-sequence (rest rule-parsers) rlist (append tree mtree))))
-      (values t token-list tree)))
-
-(defun parse-choice (rule-parsers token-list)
-  (if rule-parsers
-      (multiple-value-bind (matched rlist mtree)
-          (funcall (first rule-parsers) token-list)
-        (if matched
-            (values t rlist mtree)
-            (parse-choice (rest rule-parsers) token-list)))
-      nil))
-
-(defun parse-anycount (rule-parser token-list tree)
-  (multiple-value-bind (matched rlist mtree) (funcall rule-parser token-list)
-    (if matched
-        (parse-anycount rule-parser rlist (append tree mtree))
-        (values t token-list tree))))
-
-(defun parse-eqcount (count rule-parser token-list tree)
-  (if (> count 0)
-      (multiple-value-bind (matched rlist mtree)
-          (funcall rule-parser token-list)
-        (when matched
-          (parse-eqcount (1- count) rule-parser rlist (append tree mtree))))
-      (values t token-list tree)))
-
-(defun parse-mincount (count rule-parser token-list tree)
-  (if (> count 0)
-      (multiple-value-bind (matched rlist mtree)
-          (funcall rule-parser token-list)
-        (when matched
-          (parse-mincount (1- count) rule-parser rlist (append tree mtree))))
-      (parse-anycount rule-parser token-list tree)))
-
-(defun parse-maxcount (count rule-parser token-list tree)
-  (if (> count 0)
-      (multiple-value-bind (matched rlist mtree)
-          (funcall rule-parser token-list)
-        (if matched
-            (parse-maxcount (1- count) rule-parser rlist (append tree mtree))
-            (values t token-list tree)))
-      (values t token-list tree)))
-
-
-
-;; This needs to be changed to just use the function of the given
-;; symbol-name, so that any format of sequence may be supported.
-(defun make-token-parser (token-class)
-  (declare (special definition-names
-                    *import*))
-  (unless (or (member token-class definition-names)
-              (member token-class *import*))
-    (warn "Parser ~A is neither defined nor imported." token-class))
-  (if (member token-class definition-names)
-      `(function ,token-class)
-      (with-gensyms (token-list token)
-        `(lambda (,token-list)
-          (let ((,token (first ,token-list)))
-            (when (and ,token-list (eq (token-class ,token) ',token-class))
-              (values t (rest ,token-list) (list ,token))))))))
-
-(defun make-character-parser (ch)
-  (with-gensyms (str)
-    `(lambda (,str)
-      (when (and (> (length ,str) 0) (char= (char ,str 0) ,ch))
-        (values
-         t
-         (substring ,str :start 1)
-         (list ,ch))))))
-
-(defun make-regex-parser (regex)
-  (declare (special *regex-flags*))
-  (let ((regex `(:sequence (:flags ,@*regex-flags*) :start-anchor
-                 (:register (:regex ,regex)))))
-    (with-gensyms (str start end)
-      `(lambda (,str)
-        (multiple-value-bind (,start ,end) (scan (quote ,regex) ,str)
-          (when ,start
-            (values
-             t
-             (substring ,str :start ,end)
-             (list (substring ,str :end ,end)))))))))
-
-
-(defun make-sequence-parser (rules)
-  (with-gensyms (rule-parsers token-list)
-    `(let ((,rule-parsers (list ,@(mapcar #'make-parser rules))))
-      (lambda (,token-list) (parse-sequence ,rule-parsers ,token-list nil)))))
-
-(defun make-choice-parser (rules)
-  (with-gensyms (rule-parsers token-list)
-    `(let ((,rule-parsers (list ,@(mapcar #'make-parser rules))))
-      (lambda (,token-list) (parse-choice ,rule-parsers ,token-list)))))
-
-(defun make-anycount-parser (rule)
-  (with-gensyms (rule-parser token-list)
-    `(let ((,rule-parser ,(make-parser rule)))
-      (lambda (,token-list) (parse-anycount ,rule-parser ,token-list nil)))))
-
-(defun make-eqcount-parser (count rule)
-  (with-gensyms (rule-parser token-list)
-    `(let ((,rule-parser ,(make-parser rule)))
-      (lambda (,token-list)
-        (parse-eqcount ,count ,rule-parser ,token-list nil)))))
-
-(defun make-maxcount-parser (count rule)
-  (with-gensyms (rule-parser token-list)
-    `(let ((,rule-parser ,(make-parser rule)))
-      (lambda (,token-list)
-        (parse-maxcount ,count ,rule-parser ,token-list nil)))))
-
-(defun make-0or1-parser (rule) (make-maxcount-parser 1 rule))
-
-(defun make-+-parser (rule)
-  (with-gensyms (rule-parser token-list)
-    `(let ((,rule-parser ,(make-parser rule)))
-      (lambda (,token-list)
-        (parse-mincount 1 ,rule-parser ,token-list nil)))))
-
-(defun make-required-pred (rule)
-  (with-gensyms (rule-parser token-list)
-    `(let ((,rule-parser ,(make-parser rule)))
-      (lambda (,token-list)
-        (when (funcall ,rule-parser ,token-list)
-          (values t ,token-list nil))))))
-
-(defun make-forbidden-pred (rule)
-  (with-gensyms (rule-parser token-list)
-    `(let ((,rule-parser ,(make-parser rule)))
-      (lambda (,token-list)
-        (unless (funcall ,rule-parser ,token-list)
-          (values t ,token-list nil))))))
-
-(defun make-match-parser (rule)
-  (with-gensyms (rule-parser token-list matched rlist)
-    `(let ((,rule-parser ,(make-parser rule)))
-      (lambda (,token-list)
-        (multiple-value-bind (,matched ,rlist)
-            (funcall ,rule-parser ,token-list)
-          (when ,matched (values t ,rlist nil)))))))
-
-(defmacro dispatch (sym fun)
-  `(progn
-    (when (cddr rule) (error ,(format nil "~A takes one argument" sym)))
-    (,fun (second rule))))
-
-(setf (symbol-function 'make-parser) (lambda (rule)
-  (etypecase rule
-    (symbol (make-token-parser rule))
-    (character (make-character-parser rule))
-    (string (make-regex-parser rule))
-    (list
-     (if (symbolp (first rule))
-         (scase (first rule)
-           (& (dispatch & make-required-pred))
-           (! (dispatch ! make-forbidden-pred))
-           (* (dispatch * make-anycount-parser))
-           (? (dispatch ? make-0or1-parser))
-           (+ (dispatch + make-+-parser))
-           (= (make-match-parser (cdr rule)))
-           (/ (make-choice-parser (cdr rule)))
-           (t (make-sequence-parser rule)))
-         (make-sequence-parser rule))))))
-
-
-
-
 (defun hash-names (names &optional (map (make-hash-table)))
   (if names