From: Chris Hanson Date: Sat, 30 Jun 2001 03:23:59 +0000 (+0000) Subject: Add WITH-POINTER to both parser and matcher languages. Also implement X-Git-Tag: 20090517-FFI~2687 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=9ec7a159b08bbf9bc78a81729777b9b02c6679fe;p=mit-scheme.git 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 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))))