From 9ec7a159b08bbf9bc78a81729777b9b02c6679fe Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 30 Jun 2001 03:23:59 +0000
Subject: [PATCH] Add WITH-POINTER to both parser and matcher languages. Also
implement macros for both languages.
---
v7/src/star-parser/load.scm | 4 +-
v7/src/star-parser/matcher.scm | 75 +++++++++++++++++++++++-----------
v7/src/star-parser/parser.pkg | 6 ++-
v7/src/star-parser/parser.scm | 41 +++++++++++++++++--
v7/src/star-parser/shared.scm | 32 ++++++++++-----
5 files changed, 116 insertions(+), 42 deletions(-)
diff --git a/v7/src/star-parser/load.scm b/v7/src/star-parser/load.scm
index 19f4bf80c..c1b925ec3 100644
--- 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 4f84cd768..68e92bd14 100644
--- 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 @@
;;;; 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))
;;;; 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)))))
(define-matcher (* expression)
if-fail
diff --git a/v7/src/star-parser/parser.pkg b/v7/src/star-parser/parser.pkg
index 8e17fd59c..144d8d290 100644
--- 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 950603272..30c9dda91 100644
--- 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))
;;;; Parsers
@@ -169,7 +195,7 @@
(compile-parser-expression parser pointers if-succeed
(lambda (pointers)
(if-succeed pointers `(VECTOR ,value)))))
-
+
(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))))
-
+
(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)))))
+
(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 3b46355dd..cad7ea7f3 100644
--- 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)))))))
;;;; Buffer pointers
@@ -205,15 +219,13 @@
(not (eq? (cadddr expression) '#T)))
(lambda (expression)
`(AND (NOT ,(cadr expression)) ,(cadddr expression))))
-
+
(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))))
+
(define-optimizer '('IF EXPRESSION EXPRESSION 'UNSPECIFIC) #f
(lambda (expression)
`(IF ,(cadr expression) ,(caddr expression))))
--
2.25.1