From fd88d86ced6955446c54dfd7b54d7664fd5a730b Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Wed, 3 Sep 2008 02:49:09 +0000 Subject: [PATCH] Implement LIST-PARSER macro. --- v7/src/runtime/ed-ffi.scm | 3 +- v7/src/runtime/list-parser.scm | 508 +++++++++++++++++++++++++++++++++ v7/src/runtime/runtime.pkg | 9 +- 3 files changed, 518 insertions(+), 2 deletions(-) create mode 100644 v7/src/runtime/list-parser.scm diff --git a/v7/src/runtime/ed-ffi.scm b/v7/src/runtime/ed-ffi.scm index 5dd335e75..a29cb58fc 100644 --- a/v7/src/runtime/ed-ffi.scm +++ b/v7/src/runtime/ed-ffi.scm @@ -1,6 +1,6 @@ #| -*- Scheme -*- -$Id: ed-ffi.scm,v 1.42 2008/08/24 07:20:01 cph Exp $ +$Id: ed-ffi.scm,v 1.43 2008/09/03 02:49:03 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -95,6 +95,7 @@ USA. ("lambda" (runtime lambda-abstraction)) ("lambdx" (runtime alternative-lambda)) ("list" (runtime list)) + ("list-parser" (runtime list-parser)) ("load" (runtime load)) ("mime-codec" (runtime mime-codec)) ("mit-syntax" (runtime syntactic-closures)) diff --git a/v7/src/runtime/list-parser.scm b/v7/src/runtime/list-parser.scm new file mode 100644 index 000000000..886129200 --- /dev/null +++ b/v7/src/runtime/list-parser.scm @@ -0,0 +1,508 @@ +#| -*-Scheme-*- + +$Id: list-parser.scm,v 1.1 2008/09/03 02:49:06 cph Exp $ + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Parsing language for flat lists +;;; package: (runtime list-parser) + +(declare (usual-integrations)) + +(define-syntax list-parser + (sc-macro-transformer + (lambda (form env) + (if (syntax-match? '(FORM) (cdr form)) + (compile-top-level (cadr form) env) + (ill-formed-syntax form))))) + +(define (compile-top-level pattern env) + (fluid-let ((name-counters (make-strong-eq-hash-table))) + (make-lambda '(ITEMS WIN LOSE) + (lambda (items win lose) + (optimize-result (compile-pattern pattern env items win lose)))))) + +(define (compile-pattern pattern env items win lose) + (cond ((rewrite-pattern pattern) + => (lambda (pattern) + (compile-pattern pattern env items win lose))) + ((and (pair? pattern) + (interned-symbol? (car pattern)) + (let ((c (get-pattern-compiler (car pattern)))) + (and (syntax-match? (car c) (cdr pattern)) + (cdr c)))) + => (lambda (compiler) + (compiler pattern env items win lose))) + (else + (error "Unrecognized list pattern:" pattern)))) + +(define (rewrite-pattern pattern) + (cond ((identifier? pattern) + `(SEXP ,pattern)) + ((or (char? pattern) + (string? pattern) + (number? pattern) + (boolean? pattern) + (null? pattern)) + `(QUOTE ,pattern)) + ((syntax-match? '('+ * FORM) pattern) + `(SEQ ,@(cdr pattern) (* ,@(cdr pattern)))) + (else #f))) + +(define (get-pattern-compiler name) + (let ((p (assq name pattern-compilers))) + (and p + (cdr p)))) + +(define (define-pattern-compiler template compiler) + (let ((name (car template)) + (value (cons (cdr template) compiler))) + (let ((p (assq name pattern-compilers))) + (if p + (set-cdr! p value) + (begin + (set! pattern-compilers + (cons (cons name value) + pattern-compilers)) + unspecific))))) + +(define pattern-compilers '()) + +(define (terminal items lose make-test make-body) + (make-let '(ITEMS LOSE) + (list items lose) + (lambda (items lose) + `(IF ,(make-test items) + ,(make-body items lose) + (,lose))))) + +(define-pattern-compiler '(MATCH-NULL) + (lambda (pattern env items win lose) + pattern env + (terminal items lose + (lambda (items) + `(NULL? ,items)) + (lambda (items lose) + `(,win ,items ,(null-vals) ,lose))))) + +(define-pattern-compiler '(MATCH-ANY) + (lambda (pattern env items win lose) + pattern env + (terminal items lose + (lambda (items) + `(PAIR? ,items)) + (lambda (items lose) + `(,win (CDR ,items) ,(single-val `(CAR ,items)) ,lose))))) + +(define-pattern-compiler '(MATCH-IF EXPRESSION) + (lambda (pattern env items win lose) + (terminal items lose + (lambda (items) + `(AND (PAIR? ,items) + (,(close-syntax (cadr pattern) env) (CAR ,items)))) + (lambda (items lose) + `(,win (CDR ,items) ,(single-val `(CAR ,items)) ,lose))))) + +(define-pattern-compiler '(NOISE-IF EXPRESSION) + (lambda (pattern env items win lose) + (terminal items lose + (lambda (items) + `(AND (PAIR? ,items) + (,(close-syntax (cadr pattern) env) (CAR ,items)))) + (lambda (items lose) + `(,win (CDR ,items) ,(null-vals) ,lose))))) + +(define-pattern-compiler '(QUOTE DATUM) + (lambda (pattern env items win lose) + env + (terminal items lose + (let ((datum (cadr pattern))) + (lambda (items) + `(AND (PAIR? ,items) + (,(cond ((or (symbol? datum) + (char? datum) + (boolean? datum) + (null? datum)) + 'EQ?) + ((number? datum) 'EQV?) + (else 'EQUAL?)) + (CAR ,items) + ',datum)))) + (lambda (items lose) + `(,win (CDR ,items) ,(null-vals) ,lose))))) + +(define-pattern-compiler '(LIST * FORM) + (lambda (pattern env items win lose) + (terminal items lose + (lambda (items) + `(PAIR? ,items)) + (lambda (items lose) + (compile-pattern `(SEQ ,@(cdr pattern)) + env + `(CAR ,items) + (make-winner + (lambda (items* vals lose) + (fork-loser lose + (lambda (lose) + `(IF (NULL? ,items*) + (,win (CDR ,items) ,vals ,lose) + (,lose)))))) + lose))))) + +(define-pattern-compiler '(SEXP EXPRESSION) + (lambda (pattern env items win lose) + `(,(close-syntax (cadr pattern) env) ,items ,win ,lose))) + +(define-pattern-compiler '(NOISE FORM) + (lambda (pattern env items win lose) + (compile-pattern (cadr pattern) + env + items + (make-winner + (lambda (items vals lose) + vals + `(,win ,items ,(null-vals) ,lose))) + lose))) + +(define-pattern-compiler '(? * FORM) + (lambda (pattern env items win lose) + (compile-pattern `(SEQ ,@(cdr pattern)) + env + items + win + (make-loser + `(,win ,items ,(null-vals) ,lose))))) + +(define-pattern-compiler '(* * FORM) + (lambda (pattern env items win lose) + (make-loop '(ITEMS VALS LOSE) + (list items (null-vals) lose) + (lambda (loop items* vals lose*) + (compile-pattern `(SEQ ,@(cdr pattern)) + env + items* + (make-winner + (lambda (items vals* lose) + `(,loop ,items + ,(join-vals vals vals*) + ,lose))) + (make-loser + `(,win ,items* ,vals ,lose*))))))) + +(define-pattern-compiler '(SEQ * FORM) + (lambda (pattern env items win lose) + (let ((patterns (cdr pattern))) + (if (pair? patterns) + (if (pair? (cdr patterns)) + (let loop + ((patterns patterns) + (items items) + (vals (null-vals)) + (lose lose)) + (if (pair? patterns) + (compile-pattern (car patterns) + env + items + (make-winner + (lambda (items vals* lose) + (loop (cdr patterns) + items + (join-vals vals vals*) + lose))) + lose) + `(,win ,items ,vals ,lose))) + (compile-pattern (car patterns) env items win lose)) + `(,win ,items ,(null-vals) ,lose))))) + +(define-pattern-compiler '(ALT * FORM) + (lambda (pattern env items win lose) + (let ((patterns (cdr pattern))) + (if (pair? patterns) + (fork-winner win + (lambda (win) + (let loop ((patterns patterns)) + (let ((k + (lambda (lose) + (compile-pattern (car patterns) env items win lose)))) + (if (pair? (cdr patterns)) + (fork-loser (make-loser (loop (cdr patterns))) + k) + (k lose)))))) + `(,lose))))) + +(define-pattern-compiler '(MAP EXPRESSION FORM) + (lambda (pattern env items win lose) + (compile-pattern (caddr pattern) + env + items + (make-winner + (lambda (items vals lose) + `(,win ,items + (map ,(close-syntax (cadr pattern) env) + (LIST-PARSER-VALS->LIST ,vals)) + ,lose))) + lose))) + +(define-pattern-compiler '(ENCAPSULATE EXPRESSION FORM) + (lambda (pattern env items win lose) + (compile-pattern (caddr pattern) + env + items + (make-winner + (lambda (items vals lose) + `(,win ,items + ,(single-val + `(APPLY ,(close-syntax (cadr pattern) env) + (LIST-PARSER-VALS->LIST ,vals))) + ,lose))) + lose))) + +(define-pattern-compiler '(TRANSFORM EXPRESSION FORM) + (lambda (pattern env items win lose) + (compile-pattern (caddr pattern) + env + items + (make-winner + (lambda (items vals lose) + `(,win ,items + (APPLY ,(close-syntax (cadr pattern) env) + (LIST-PARSER-VALS->LIST ,vals)) + ,lose))) + lose))) + +(define (make-winner procedure) + (make-lambda '(ITEMS VALS LOSE) procedure)) + +(define (make-loser body) + (make-lambda '() (lambda () body))) + +(define (fork-winner win procedure) + (make-let '(WIN) (list win) procedure)) + +(define (fork-loser lose procedure) + (make-let '(LOSE) (list lose) procedure)) + +(define (make-lambda names make-body) + (call-with-new-names names + (lambda names + `(LAMBDA ,names + ,(apply make-body names))))) + +(define (make-let names args make-body) + (call-with-new-names names + (lambda names + `((LAMBDA ,names + ,(apply make-body names)) + ,@args)))) + +(define (make-loop names inits make-body) + (call-with-new-names (cons 'LOOP names) + (lambda names + `(LET ,(car names) + ,(map (lambda (name init) + `(,name ,init)) + (cdr names) + inits) + ,(apply make-body names))))) + +(define (call-with-new-names names procedure) + (apply procedure + (map (lambda (name) + (let ((n (hash-table-ref/default name-counters name 0))) + (hash-table-set! name-counters name (+ n 1)) + (symbol name '. n))) + names))) + +(define name-counters) + +(define (join-vals vals1 vals2) + `(CONS ,vals1 ,vals2)) + +(define (single-val val) + `(CONS ',single-val-marker ,val)) + +(define (null-vals) + ''()) + +;; Needed at runtime by parsers: +(define (list-parser-vals->list vals) + (let loop ((vals vals) (items '()) (k reverse!)) + (if (pair? vals) + (if (eq? (car vals) single-val-marker) + (k (cons (cdr vals) items)) + (loop (car vals) + items + (lambda (items) + (loop (cdr vals) + items + k)))) + (k items)))) + +(define single-val-marker + '|#[(runtime list-parser)single-val-marker]|) + +;;;; Optimization + +;;; Made easier by two facts: each bound name is unique, and we never +;;; copy expressions. + +(define (optimize-result expr) + (if enable-optimizer? + (optimize-cons (optimize-lets expr)) + expr)) + +(define enable-optimizer? #t) + +(define (optimize-lets expr) + (walk-expr expr + rewrite-constant + rewrite-quote + rewrite-reference + rewrite-lambda + rewrite-loop + (lambda (expr loop) + (let ((expr (rewrite-combination expr loop))) + (if (syntax-match? '('LAMBDA (* SYMBOL) EXPRESSION) + (car expr)) + (optimize-let (cadar expr) + (cdr expr) + (caddar expr) + loop) + expr))))) + +(define (optimize-let names vals body loop) + (let ((vals (map loop vals)) + (body (loop body))) + (let ((bindings + (remove (lambda (b*) (= (car b*) 0)) + (map (lambda (name value) + (cons (count-refs-in name body) + (cons name value))) + names + vals)))) + (receive (to-substitute to-keep) + (partition (lambda (b*) + (or (= (car b*) 1) + (symbol? (cddr b*)))) + bindings) + (let ((new-body + (optimize-lets + (if (pair? to-substitute) + (substitute (map cdr to-substitute) body) + body)))) + (if (pair? to-keep) + `((LAMBDA ,(map cadr to-keep) ,new-body) + ,@(map cddr to-keep)) + new-body)))))) + +(define (optimize-cons expr) + (walk-expr expr + rewrite-constant + rewrite-quote + rewrite-reference + rewrite-lambda + rewrite-loop + (lambda (expr loop) + (let ((expr (rewrite-combination expr loop))) + (if (and (eq? (car expr) 'CONS) + (not (equal? (cadr expr) `',single-val-marker))) + (optimize-cons-1 (cadr expr) (caddr expr)) + expr))))) + +(define (optimize-cons-1 car-expr cdr-expr) + (let ((car-expr (optimize-cons car-expr)) + (cdr-expr (optimize-cons cdr-expr))) + (cond ((equal? car-expr (null-vals)) cdr-expr) + ((equal? cdr-expr (null-vals)) car-expr) + (else `(CONS ,car-expr ,cdr-expr))))) + +(define (count-refs-in name expr) + (walk-expr expr + (lambda (expr) expr 0) + (lambda (expr) expr 0) + (lambda (expr) (if (eq? expr name) 1 0)) + (lambda (expr loop) (loop (caddr expr))) + (lambda (expr loop) + (+ (apply + + (map (lambda (binding) + (loop (cadr binding))) + (caddr expr))) + (loop (cadddr expr)))) + (lambda (expr loop) (apply + (map loop expr))))) + +(define (substitute bindings expr) + (walk-expr expr + rewrite-constant + rewrite-quote + (lambda (expr) + (let ((expr (rewrite-reference expr))) + (let ((p (assq expr bindings))) + (if p + (cdr p) + expr)))) + rewrite-lambda + rewrite-loop + rewrite-combination)) + +(define (walk-expr expr + if-constant if-quote if-reference + if-lambda if-loop if-combination) + (let loop ((expr expr)) + (cond ((syntax-match? '('LAMBDA (* SYMBOL) EXPRESSION) expr) + (if-lambda expr loop)) + ((syntax-match? '('LET SYMBOL (* (SYMBOL EXPRESSION)) EXPRESSION) + expr) + (if-loop expr loop)) + ((syntax-match? '('QUOTE EXPRESSION) expr) + (if-quote expr)) + ((syntax-match? '(+ EXPRESSION) expr) + (if-combination expr loop)) + ((syntax-match? 'IDENTIFIER expr) + (if-reference expr)) + (else + (if-constant expr))))) + +(define (rewrite-constant expr) + expr) + +(define (rewrite-quote expr) + expr) + +(define (rewrite-reference expr) + expr) + +(define (rewrite-lambda expr loop) + `(LAMBDA ,(cadr expr) + ,(loop (caddr expr)))) + +(define (rewrite-loop expr loop) + `(LET ,(cadr expr) + ,(map (lambda (binding) + (list (car binding) + (loop (cadr binding)))) + (caddr expr)) + ,(loop (cadddr expr)))) + +(define (rewrite-combination expr loop) + (map loop expr)) \ No newline at end of file diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index 872008c63..fdfda1851 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.669 2008/08/31 07:36:17 cph Exp $ +$Id: runtime.pkg,v 14.670 2008/09/03 02:49:09 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -5276,6 +5276,13 @@ USA. encode-www-form-urlencoded) (initialization (initialize-package!))) +(define-package (runtime list-parser) + (files "list-parser") + (parent (runtime)) + (export () + list-parser + list-parser-vals->list)) + (define-package (runtime postgresql) (file-case options ((load) "pgsql") -- 2.25.1