From: Chris Hanson Date: Sat, 30 Jun 2001 06:05:35 +0000 (+0000) Subject: Add ability to specify macros that are symbols rather than forms. X-Git-Tag: 20090517-FFI~2686 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=26fcd65687d9dcda81cd44ef3cc5b2c3999a2747;p=mit-scheme.git Add ability to specify macros that are symbols rather than forms. These expand to fixed parser sequences. --- diff --git a/v7/src/star-parser/load.scm b/v7/src/star-parser/load.scm index c1b925ec3..150e24aa1 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.2 2001/06/30 03:23:59 cph Exp $ +;;; $Id: load.scm,v 1.3 2001/06/30 06:05:35 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 2)) \ No newline at end of file +(add-subsystem-identification! "*Parser" '(0 3)) \ No newline at end of file diff --git a/v7/src/star-parser/matcher.scm b/v7/src/star-parser/matcher.scm index 68e92bd14..f1681bfa0 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.6 2001/06/30 03:23:34 cph Exp $ +;;; $Id: matcher.scm,v 1.7 2001/06/30 06:05:19 cph Exp $ ;;; ;;; Copyright (c) 2001 Massachusetts Institute of Technology ;;; @@ -37,14 +37,6 @@ (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) (let ((external-bindings (list 'BINDINGS)) (internal-bindings (list 'BINDINGS))) @@ -86,6 +78,29 @@ ,(if-fail pointers))))) (else (error "Malformed matcher:" expression)))) + +(syntax-table/define system-global-syntax-table 'DEFINE-*MATCHER-MACRO + (lambda (bvl expression) + (cond ((symbol? bvl) + `(DEFINE-*MATCHER-MACRO* ',bvl + (LAMBDA () + ,expression))) + ((named-lambda-bvl? bvl) + `(DEFINE-*MATCHER-MACRO* ',(car bvl) + (LAMBDA ,(cdr bvl) + ,expression))) + (else + (error "Malformed bound-variable list:" bvl))))) + +(define (define-*matcher-macro* name procedure) + (hash-table/put! *matcher-macros name procedure) + name) + +(define (*matcher-expander name) + (hash-table/get *matcher-macros name #f)) + +(define *matcher-macros + (make-eq-hash-table)) ;;;; Canonicalization @@ -148,23 +163,18 @@ (handle-complex-expression (check-1-arg expression) internal-bindings)) (else - (let ((expander - (hash-table/get *matcher-macros (car expression) #f))) + (let ((expander (*matcher-expander (car expression)))) (if expander (do-expression (apply expander (cdr expression))) (error "Unknown matcher expression:" expression)))))) ((symbol? expression) - expression) + (let ((expander (*matcher-expander expression))) + (if expander + (do-expression (expander)) + 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 diff --git a/v7/src/star-parser/parser.scm b/v7/src/star-parser/parser.scm index 30c9dda91..26e777f1d 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.10 2001/06/30 03:23:41 cph Exp $ +;;; $Id: parser.scm,v 1.11 2001/06/30 06:05:09 cph Exp $ ;;; ;;; Copyright (c) 2001 Massachusetts Institute of Technology ;;; @@ -37,14 +37,6 @@ (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) @@ -82,6 +74,29 @@ ,(if-fail pointers))))))) (else (error "Malformed matcher:" expression)))) + +(syntax-table/define system-global-syntax-table 'DEFINE-*PARSER-MACRO + (lambda (bvl expression) + (cond ((symbol? bvl) + `(DEFINE-*PARSER-MACRO* ',bvl + (LAMBDA () + ,expression))) + ((named-lambda-bvl? bvl) + `(DEFINE-*PARSER-MACRO* ',(car bvl) + (LAMBDA ,(cdr bvl) + ,expression))) + (else + (error "Malformed bound-variable list:" bvl))))) + +(define (define-*parser-macro* name procedure) + (hash-table/put! *parser-macros name procedure) + name) + +(define (*parser-expander name) + (hash-table/get *parser-macros name #f)) + +(define *parser-macros + (make-eq-hash-table)) ;;;; Canonicalization @@ -127,13 +142,15 @@ (handle-complex-expression (check-1-arg expression) internal-bindings)) (else - (let ((expander - (hash-table/get *parser-macros (car expression) #f))) + (let ((expander (*parser-expander (car expression)))) (if expander (do-expression (apply expander (cdr expression))) (error "Unknown parser expression:" expression)))))) ((symbol? expression) - expression) + (let ((expander (*parser-expander expression))) + (if expander + (do-expression (expander)) + expression))) (else (error "Unknown parser expression:" expression)))) (let ((expression (do-expression expression))) @@ -144,13 +161,6 @@ (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