Add WITH-POINTER to both parser and matcher languages. Also implement

macros for both languages.

diff --git a/v7/src/star-parser/load.scm b/v7/src/star-parser/load.scm
index 19f4bf80c69ff962e8fda6f305bd4115e9bf188b..c1b925ec39aaeca43e36e9937924dc9f29704dee 100644 (file)
--- a/v7/src/star-parser/load.scm
+++ b/v7/src/star-parser/load.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: load.scm,v 1.1 2001/06/26 18:03:13 cph Exp $
+;;; $Id: load.scm,v 1.2 2001/06/30 03:23:59 cph Exp $
 ;;;
 ;;; Copyright (c) 2001 Massachusetts Institute of Technology
 ;;;
@@ -24,4 +24,4 @@
   (lambda ()
     (fluid-let ((*allow-package-redefinition?* #t))
       (package/system-loader "parser" '() 'QUERY))))
-(add-subsystem-identification! "*Parser" '(0 1))
\ No newline at end of file
+(add-subsystem-identification! "*Parser" '(0 2))
\ No newline at end of file

diff --git a/v7/src/star-parser/matcher.scm b/v7/src/star-parser/matcher.scm
index 4f84cd768aa21dbe6419baa3f728cb3eaf838944..68e92bd14598057ae41e1e57eaf58f5b41ab4d6a 100644 (file)
--- a/v7/src/star-parser/matcher.scm
+++ b/v7/src/star-parser/matcher.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: matcher.scm,v 1.5 2001/06/27 02:00:08 cph Exp $
+;;; $Id: matcher.scm,v 1.6 2001/06/30 03:23:34 cph Exp $
 ;;;
 ;;; Copyright (c) 2001 Massachusetts Institute of Technology
 ;;;
@@ -37,14 +37,32 @@
   (lambda (expression)
     (optimize-expression (generate-matcher-code expression))))
 
+(syntax-table/define system-global-syntax-table 'DEFINE-*MATCHER-MACRO
+  (lambda (bvl expression)
+    (if (not (named-lambda-bvl? bvl))
+       (error "Malformed bound-variable list:" bvl))
+    `(DEFINE-*MATCHER-MACRO* ',(car bvl)
+       (LAMBDA ,(cdr bvl)
+        ,expression))))
+
 (define (generate-matcher-code expression)
-  (with-canonical-matcher-expression expression
-    (lambda (expression)
-      (compile-matcher-expression
-       expression
-       (no-pointers)
-       (simple-backtracking-continuation `#T)
-       (simple-backtracking-continuation `#F)))))
+  (let ((external-bindings (list 'BINDINGS))
+       (internal-bindings (list 'BINDINGS)))
+    (let ((expression
+          (canonicalize-matcher-expression expression
+                                           external-bindings
+                                           internal-bindings)))
+      (maybe-make-let (map (lambda (b) (list (cdr b) (car b)))
+                          (cdr external-bindings))
+       (with-buffer-name
+         (lambda ()
+           (maybe-make-let (map (lambda (b) (list (cdr b) (car b)))
+                                (cdr internal-bindings))
+                           (compile-matcher-expression
+                            expression
+                            (no-pointers)
+                            (simple-backtracking-continuation `#T)
+                            (simple-backtracking-continuation `#F)))))))))
 
 (define (compile-matcher-expression expression pointers if-succeed if-fail)
   (cond ((and (pair? expression)
@@ -71,21 +89,6 @@
 \f
 ;;;; Canonicalization
 
-(define (with-canonical-matcher-expression expression receiver)
-  (let ((external-bindings (list 'BINDINGS))
-       (internal-bindings (list 'BINDINGS)))
-    (let ((expression
-          (canonicalize-matcher-expression expression
-                                           external-bindings
-                                           internal-bindings)))
-      (maybe-make-let (map (lambda (b) (list (cdr b) (car b)))
-                          (cdr external-bindings))
-       (with-buffer-name
-         (lambda ()
-           (maybe-make-let (map (lambda (b) (list (cdr b) (car b)))
-                                (cdr internal-bindings))
-             (receiver expression))))))))
-
 (define (canonicalize-matcher-expression expression
                                         external-bindings internal-bindings)
   (define (do-expression expression)
@@ -135,16 +138,33 @@
                            `(RE-COMPILE-CHAR-SET ,arg #F))
                        external-bindings)
                       (handle-complex-expression arg internal-bindings)))))
+            ((WITH-POINTER)
+             (check-2-args expression
+                           (lambda (expression) (symbol? (cadr expression))))
+             `(,(car expression)
+               ,(cadr expression)
+               ,(do-expression (caddr expression))))
             ((SEXP)
              (handle-complex-expression (check-1-arg expression)
                                         internal-bindings))
             (else
-             (error "Unknown matcher expression:" expression))))
+             (let ((expander
+                    (hash-table/get *matcher-macros (car expression) #f)))
+               (if expander
+                   (do-expression (apply expander (cdr expression)))
+                   (error "Unknown matcher expression:" expression))))))
          ((symbol? expression)
           expression)
          (else
           (error "Unknown matcher expression:" expression))))
   (do-expression expression))
+
+(define (define-*matcher-macro* name procedure)
+  (hash-table/put! *matcher-macros name procedure)
+  name)
+
+(define *matcher-macros
+  (make-eq-hash-table))
 \f
 ;;;; Matchers
 
@@ -194,6 +214,13 @@
 
 (define-atomic-matcher (string-ci string)
   `(MATCH-PARSER-BUFFER-STRING-CI ,*buffer-name* ,string))
+
+(define-matcher (with-pointer identifier expression)
+  (with-current-pointer pointers
+    (lambda (pointers)
+      `(LET ((,identifier ,(current-pointer pointers)))
+        ,(compile-matcher-expression expression pointers
+                                     if-succeed if-fail)))))
 \f
 (define-matcher (* expression)
   if-fail

diff --git a/v7/src/star-parser/parser.pkg b/v7/src/star-parser/parser.pkg
index 8e17fd59cceb53010b41c55f2d7d7c21364abb44..144d8d2902f6bfed5563cc7dfd1067c5b4685406 100644 (file)
--- a/v7/src/star-parser/parser.pkg
+++ b/v7/src/star-parser/parser.pkg
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: parser.pkg,v 1.3 2001/06/29 05:17:24 cph Exp $
+;;; $Id: parser.pkg,v 1.4 2001/06/30 03:23:38 cph Exp $
 ;;;
 ;;; Copyright (c) 2001 Massachusetts Institute of Technology
 ;;;
@@ -65,4 +65,6 @@
 (define-package (runtime *parser)
   (files "synchk" "shared" "matcher" "parser")
   (parent ())
-  (export ()))
\ No newline at end of file
+  (export ()
+         define-*matcher-macro*
+         define-*parser-macro*))
\ No newline at end of file

diff --git a/v7/src/star-parser/parser.scm b/v7/src/star-parser/parser.scm
index 9506032728acc97dfef5c49ebbcb7154dbb06074..30c9dda91ab7f7355436fc9d2a4f6e78117fadb7 100644 (file)
--- a/v7/src/star-parser/parser.scm
+++ b/v7/src/star-parser/parser.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: parser.scm,v 1.9 2001/06/27 01:57:16 cph Exp $
+;;; $Id: parser.scm,v 1.10 2001/06/30 03:23:41 cph Exp $
 ;;;
 ;;; Copyright (c) 2001 Massachusetts Institute of Technology
 ;;;
@@ -37,6 +37,14 @@
   (lambda (expression)
     (optimize-expression (generate-parser-code expression))))
 
+(syntax-table/define system-global-syntax-table 'DEFINE-*PARSER-MACRO
+  (lambda (bvl expression)
+    (if (not (named-lambda-bvl? bvl))
+       (error "Malformed bound-variable list:" bvl))
+    `(DEFINE-*PARSER-MACRO* ',(car bvl)
+       (LAMBDA ,(cdr bvl)
+        ,expression))))
+
 (define (generate-parser-code expression)
   (with-canonical-parser-expression expression
     (lambda (expression)
@@ -108,11 +116,22 @@
                (check-2-args expression)
                `(,(car expression) ,(cadr expression)
                                    ,(do-expression (caddr expression))))
+              ((WITH-POINTER)
+               (check-2-args expression
+                             (lambda (expression)
+                               (symbol? (cadr expression))))
+               `(,(car expression)
+                 ,(cadr expression)
+                 ,(do-expression (caddr expression))))
               ((SEXP)
                (handle-complex-expression (check-1-arg expression)
                                           internal-bindings))
               (else
-               (error "Unknown parser expression:" expression))))
+               (let ((expander
+                      (hash-table/get *parser-macros (car expression) #f)))
+                 (if expander
+                     (do-expression (apply expander (cdr expression)))
+                     (error "Unknown parser expression:" expression))))))
            ((symbol? expression)
             expression)
            (else
@@ -125,6 +144,13 @@
            (maybe-make-let (map (lambda (b) (list (cdr b) (car b)))
                                 (cdr internal-bindings))
              (receiver expression))))))))
+
+(define (define-*parser-macro* name procedure)
+  (hash-table/put! *parser-macros name procedure)
+  name)
+
+(define *parser-macros
+  (make-eq-hash-table))
 \f
 ;;;; Parsers
 
@@ -169,7 +195,7 @@
   (compile-parser-expression parser pointers if-succeed
     (lambda (pointers)
       (if-succeed pointers `(VECTOR ,value)))))
-
+\f
 (define-parser (transform transform parser)
   (with-current-pointer pointers
     (lambda (start-pointers)
@@ -206,7 +232,7 @@
                 (DISCARD-PARSER-BUFFER-HEAD! ,*buffer-name*)
                 ,(if-succeed pointers result))))
        if-fail))))
-\f
+
 (define-parser (top-level parser)
   (compile-parser-expression parser pointers
     (lambda (pointers result)
@@ -215,6 +241,13 @@
         ,(if-succeed pointers result)))
     if-fail))
 
+(define-parser (with-pointer identifier expression)
+  (with-current-pointer pointers
+    (lambda (pointers)
+      `(LET ((,identifier ,(current-pointer pointers)))
+        ,(compile-parser-expression expression pointers
+                                    if-succeed if-fail)))))
+\f
 (define-parser (seq . ps)
   (if (pair? ps)
       (if (pair? (cdr ps))

diff --git a/v7/src/star-parser/shared.scm b/v7/src/star-parser/shared.scm
index 3b46355dd53f496b04606d84515e8671b8f89a45..cad7ea7f3f6b99f75904b2f538b327fb0c72909c 100644 (file)
--- a/v7/src/star-parser/shared.scm
+++ b/v7/src/star-parser/shared.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: shared.scm,v 1.4 2001/06/26 23:46:20 cph Exp $
+;;; $Id: shared.scm,v 1.5 2001/06/30 03:23:45 cph Exp $
 ;;;
 ;;; Copyright (c) 2001 Massachusetts Institute of Technology
 ;;;
@@ -46,16 +46,20 @@
       `(LET ,bindings ,body)
       body))
 
-(define (check-1-arg expression)
+(define (check-1-arg expression #!optional predicate)
   (if (and (pair? (cdr expression))
-          (null? (cddr expression)))
+          (null? (cddr expression))
+          (or (default-object? predicate)
+              (predicate expression)))
       (cadr expression)
       (error "Malformed expression:" expression)))
 
-(define (check-2-args expression)
+(define (check-2-args expression #!optional predicate)
   (if (not (and (pair? (cdr expression))
                (pair? (cddr expression))
-               (null? (cdddr expression))))
+               (null? (cdddr expression))
+               (or (default-object? predicate)
+                   (predicate expression))))
       (error "Malformed expression:" expression)))
 
 (define (handle-complex-expression expression bindings)
@@ -73,6 +77,16 @@
                        (cons (cons expression variable)
                              (cdr bindings)))
              variable)))))
+
+(define (named-lambda-bvl? object)
+  (and (pair? object)
+       (symbol? (car object))
+       (let loop ((object (cdr object)))
+        (or (null? object)
+            (symbol? object)
+            (and (pair? object)
+                 (symbol? (car object))
+                 (loop (cdr object)))))))
 \f
 ;;;; Buffer pointers
 
@@ -205,15 +219,13 @@
       (not (eq? (cadddr expression) '#T)))
   (lambda (expression)
     `(AND (NOT ,(cadr expression)) ,(cadddr expression))))
-\f
+
 (define-optimizer '('IF EXPRESSION EXPRESSION EXPRESSION)
     (lambda (expression)
       (equal? (caddr expression) (cadddr expression)))
   (lambda (expression)
-    `(BEGIN
-       ,(cadr expression)
-       ,(caddr expression))))
-
+    `(BEGIN ,(cadr expression) ,(caddr expression))))
+\f
 (define-optimizer '('IF EXPRESSION EXPRESSION 'UNSPECIFIC) #f
   (lambda (expression)
     `(IF ,(cadr expression) ,(caddr expression))))