mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-04 03:00:20 +02:00
66ff15e2f0
* module/Makefile.am: Add language/sassy.scm. Probably EXTRA_DIST the dependant files, too. * module/language/sassy.scm: New file, the sassy loader. Sassy is originally R5RS code that loads a number of files. I've converted that toplevel file to be a Guile module that *includes* the subfiles, so that it all gets compiled together. It's a pretty bad hack though, because what I should be doing is including them relative to the sassy.scm source location, but we don't know that at expansion time. Something to fix. really bad hack in it so that it will compile correctly -- p * module/language/sassy/: All the sassy files and some changelog information. All of these files are LGPLv2.1+, so they can be included in Guile. * test-suite/standalone/sassy/tests/: Add the sassy unit tests. * test-suite/standalone/Makefile.am: * test-suite/standalone/test-sassy: Hook the sassy unit tests up to our test suite.
491 lines
14 KiB
Scheme
491 lines
14 KiB
Scheme
; meta-lambda.scm - A simple parser generator
|
|
; Copyright (C) 2005 Jonathan Kraut
|
|
|
|
; This library is free software; you can redistribute it and/or
|
|
; modify it under the terms of the GNU Lesser General Public
|
|
; License as published by the Free Software Foundation; either
|
|
; version 2.1 of the License, or (at your option) any later version.
|
|
|
|
; This library 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
|
|
; Lesser General Public License for more details.
|
|
|
|
; You should have received a copy of the GNU Lesser General Public
|
|
; License along with this library; if not, write to the Free Software
|
|
; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
|
|
|
|
; Contact:
|
|
; Jonathan Kraut
|
|
; 4130 43 ST #C2
|
|
; Sunnyside, NY 11104
|
|
; jak76@columbia.edu
|
|
|
|
; see file COPYING in the top of Sassy's distribution directory
|
|
|
|
|
|
; module meta-lambda
|
|
; export-syntax meta-lambda case-meta-lambda memoize
|
|
|
|
; Meta-lambda
|
|
; Another Henry Baker-inspired hack. see:
|
|
; http://home.pipeline.com/~hbaker1/Prag-Parse.html
|
|
|
|
; See after the code for documentation
|
|
|
|
|
|
(define-syntax meta-expand
|
|
(syntax-rules (or and lambda begin quote unquote
|
|
unquote-splicing __ ? + * ?* else)
|
|
((_ p i r (quote a)) (and (not (null? i))
|
|
(pair? i)
|
|
(equal? 'a (car i))
|
|
(begin (set! i (cdr i)) #t)))
|
|
((_ p i r (unquote a)) (and (not (null? i))
|
|
(pair? i)
|
|
(equal? a (car i))
|
|
(begin (set! i (cdr i)) #t)))
|
|
((_ p i r (unquote-splicing a)) (begin (set! i (list i))
|
|
(meta-expand p i r a)))
|
|
((_ p i r (or a ...)) (let ((ti i) (tp p))
|
|
(or (or (meta-expand p i r a)
|
|
(begin (set! i ti)
|
|
(set-cdr! tp '())
|
|
(set! p tp)
|
|
#f))
|
|
...)))
|
|
((_ p i r (and a ...)) (and (meta-expand p i r a) ...))
|
|
((_ p i r (lambda a b ...)) (and (null? i)
|
|
(apply (lambda a b ...) (cdr r))))
|
|
((_ p i r (begin a b ...)) (and (null? i) (begin a b ...)))
|
|
((_ p i r (else a)) (let ((tmp (a i)))
|
|
(set! i '())
|
|
tmp))
|
|
((_ p i r (+ a)) (let* ((nr (list #t))
|
|
(np nr))
|
|
(and (meta-expand np i nr a)
|
|
(do () ((not (meta-expand np i nr a))
|
|
(set! nr (list (cdr nr)))
|
|
(set-cdr! p nr)
|
|
(set! p nr)
|
|
#t)))))
|
|
((_ p i r (* a)) (let* ((nr (list #t))
|
|
(np nr))
|
|
(do () ((not (meta-expand np i nr a))
|
|
(set! nr (list (cdr nr)))
|
|
(set-cdr! p nr)
|
|
(set! p nr)
|
|
#t))))
|
|
((_ p i r (?* a)) (or (meta-expand p i r a)
|
|
#t))
|
|
((_ p i r ()) (null? i))
|
|
((_ p i r (a)) (and (not (null? i))
|
|
(pair? i)
|
|
(cond (((meta-lambda a) (car i)) =>
|
|
(lambda (res)
|
|
(if (not (eq? #t res))
|
|
(begin (set! res (list res))
|
|
(set-cdr! p res)
|
|
(set! p res)))
|
|
(set! i (cdr i))
|
|
#t))
|
|
(else #f))))
|
|
((_ p i r __) (if (or (pair? i) (null? i))
|
|
(begin (set-cdr! p i) (set! p i) (set! i '()) '__tail)
|
|
#f))
|
|
((_ p i r ?) (and (not (null? i))
|
|
(pair? i)
|
|
(let ((t (list (car i))))
|
|
(set-cdr! p t)
|
|
(set! p t)
|
|
(set! i (cdr i))
|
|
#t)))
|
|
((_ p i r x) (let-syntax ((test (syntax-rules ()
|
|
((test x w l) w)
|
|
((test y w l) l))))
|
|
(test __fubar__
|
|
(and (not (null? i))
|
|
(pair? i)
|
|
(cond ((x (car i)) =>
|
|
(lambda (res)
|
|
(let ((tmp (if (eq? res #t)
|
|
(list (car i))
|
|
(list res))))
|
|
(set-cdr! p tmp)
|
|
(set! p tmp)
|
|
(set! i (cdr i)) #t)))
|
|
(else #f)))
|
|
(and (not (null? i))
|
|
(pair? i)
|
|
(equal? x (car i))
|
|
(begin (set! i (cdr i)) #t)))))))
|
|
|
|
(define-syntax meta-lambda
|
|
(syntax-rules ()
|
|
((meta-lambda grammar)
|
|
(lambda (i)
|
|
(let* ((r (list #t))
|
|
(p r))
|
|
(cond ((meta-expand p i r grammar)
|
|
=> (lambda (res)
|
|
(if (null? i)
|
|
(if (eq? res #t)
|
|
(cond ((null? (cdr r)) #t)
|
|
((null? (cddr r)) (cadr r))
|
|
(else (cdr r)))
|
|
(if (eq? res '__tail) (cdr r) res))
|
|
#f)))
|
|
(else #f)))))))
|
|
|
|
; var-arity meta-lambda
|
|
(define-syntax meta-lambda-dot
|
|
(syntax-rules ()
|
|
((_ x y ...) (lambda args
|
|
(let ((tmp (meta-lambda x y ...)))
|
|
(tmp args))))))
|
|
|
|
; Something useful to wrap meta-lambda in to hurry things along.
|
|
; Of course only use this when not using side-effects.
|
|
(define-syntax memoize
|
|
(syntax-rules ()
|
|
((_ proc)
|
|
(let ((the-proc proc))
|
|
(let ((last-in '%#$%#%#$%)
|
|
(last-out #f))
|
|
(lambda (arg2)
|
|
(if (eq? arg2 last-in)
|
|
last-out
|
|
(begin (set! last-in arg2)
|
|
(set! last-out (the-proc arg2))
|
|
last-out))))))))
|
|
|
|
; |===========|
|
|
; |Meta-lambda|
|
|
; |===========|
|
|
|
|
; Meta-lambda is a macro for building parsers and pattern matchers
|
|
; over lists or single items. You can also specify "actions" to be
|
|
; performed when a list has been successfully parsed, so it can also
|
|
; function as a very rudimentary compiler-generator or
|
|
; attribute-grammar-generator (using synthesized attributes).
|
|
|
|
; It's really for constructing simple embedded langauges, and it has its
|
|
; limitations if your're not willing to factor out tougher grammars by
|
|
; hand. But I've found it useful.
|
|
|
|
; Here's a simple example so you can see where this is going:
|
|
|
|
; |=====|
|
|
; |Usage|
|
|
; |=====|
|
|
|
|
; meta-lambda grammer -> procedure
|
|
|
|
; Grammars are described below. The procedure generated is a procedure
|
|
; of one argument. When applied to an item (usually a list), it attempts
|
|
; to match the grammar with the list and perform any actions specified
|
|
; if it was able to completely match all the items in the list (to the
|
|
; end of the list). If the list or item can not be matched completely,
|
|
; the procedure returns #f.
|
|
|
|
; |==============|
|
|
; |The Basic Idea|
|
|
; |==============|
|
|
|
|
; Meta-lambda distinguishes between literals, and identifiers it expects
|
|
; to be bound to "predicate-like" procedures. These are procedures of one
|
|
; argument that return either #t or #f (like the usual scheme
|
|
; predicates like symbol? or number?), or another value.
|
|
|
|
; As it processes each input-item and the accompanying grammar-item, if
|
|
; the grammar-item is a literal that is equal? to the input-item, then
|
|
; meta-lambda accepts the match but discards the input item.
|
|
|
|
; If the grammar-item is a predicate-procedure, then meta-lambda applies
|
|
; that procedure to the input-item. If the result is #f, the match
|
|
; fails. If the result is #t, meta-lambda saves the input item in an
|
|
; internal accumulator-stack. If the result is any other value,
|
|
; meta-lambda saves that value in the stack, instead of the input item.
|
|
|
|
; Then, when and if the list is empty and meta-lambda encounters an
|
|
; action (expressed as a lambda expression in the grammar), meta-lambda
|
|
; applies that lambda expression to the items in the stack, and returns
|
|
; the result. (The "stack" is a list). Thus if a lambda-expression is
|
|
; supplied as an action it must contain as many arguments as there were
|
|
; predicate-procedures preceeding it.
|
|
|
|
; Since lambda-expression's denote actions to be taken at the end of a
|
|
; match (when the input-list is null), predicate procedures must be
|
|
; expressed by writing the identifier they are bound to. (No anonymous
|
|
; predicates!)
|
|
|
|
; You don't have to supply an action. In that case, if the stack is
|
|
; empty, meta-lambda returns true. If there is one item on the stack,
|
|
; meta-lambda returns that item. Otherwise, it returns the whole stack
|
|
; (as a list).
|
|
|
|
; There are other options, but that's the gist of it.
|
|
|
|
; (define match-foo-bar
|
|
; (meta-lambda
|
|
; (and 'foo 'bar (lambda () 'tada))))
|
|
|
|
; (match-foo-bar '(foo bar)) => 'tada
|
|
; (match-foo-bar '(3 cat dog)) => #f
|
|
|
|
; (define match-symbol-number-foo
|
|
; (meta-lambda
|
|
; (and symbol? number? 'foo (lambda (sym num)
|
|
; (string-append (symbol->string sym)
|
|
; (number->string num))))))
|
|
|
|
; (match-symbol-number-foo '(cat 3 foo)) => "cat3"
|
|
; (match-symbol-number-foo '(cat foo foo)) => #f
|
|
|
|
; (define both-of-em
|
|
; (meta-lambda
|
|
; (and match-foo-bar match-symbol-number-foo)))
|
|
|
|
; (both-of-em '((foo bar) (cat 3 foo))) => '(tada "cat3")
|
|
|
|
; |========|
|
|
; |Grammars|
|
|
; |========|
|
|
|
|
; grammar = (or <grammar> ...) ;choice
|
|
; | (and <grammer> ...) ;sequence
|
|
; | (+ <grammar>) ;kleene+
|
|
; | (* <grammar>) ;kleene*
|
|
; | (?* <grammar>) ;kleene?
|
|
; | <literal> ;literals
|
|
; | <identifier> ;predicate-binding
|
|
; | () ;end-of-list
|
|
; | ? ;anything
|
|
; | __ ;rest-of-list
|
|
; | (<grammar>) ;sublist
|
|
; | (unquote <identifier>) ;location
|
|
; | (unquote-splicing <grammer>) ;not-a-list
|
|
; | <action> ;result action
|
|
; | (else <procedure>) ;else-clause
|
|
|
|
; action = (lambda <formals> <body>)
|
|
; | (begin <sequence>)
|
|
|
|
; literal = (quote <scheme datum>)
|
|
; | <char>
|
|
; | <number>
|
|
; | <string>
|
|
|
|
; |==================|
|
|
; |The usual suspects|
|
|
; |==================|
|
|
|
|
; choice
|
|
; ======
|
|
|
|
; (or <grammar> ...)
|
|
|
|
; Try to match each grammar against the input in order. If a match
|
|
; fails, backtrack on the input and revert the stack.
|
|
|
|
; sequence
|
|
; ========
|
|
|
|
; (and <grammer> ...)
|
|
|
|
; Match each grammar against an item in the input, failing as soon as a
|
|
; match fails
|
|
|
|
; literals
|
|
; ========
|
|
|
|
; 'cat 'dog "three" 34 #\a '(a b c) etc.
|
|
|
|
; Compare the input item with the literal using equal?, and discard the
|
|
; input and proceed if the result is #t, otherwise fail
|
|
|
|
; identifier
|
|
; ==========
|
|
|
|
; symbol? number? boolean? match-and-do-something
|
|
|
|
; The identifier should be bound to a procedure of one argument that
|
|
; returns one value. If the result of applying the procedure to the next
|
|
; input item is #f, then fail. If the result is #t, then save the
|
|
; input-item on the stack and proceed. If the result is any other value,
|
|
; save that value on the stack in place of the input item, and proceed.
|
|
|
|
; action
|
|
; ======
|
|
|
|
; (lambda (x y) <stuff>)
|
|
; (begin (display "foo") (narfle! garthaks))
|
|
|
|
; If there is any input remaining, these immediately fail. Otherwise, if
|
|
; a "lambda", apply the lambda to the accumulated stack of
|
|
; predicate-matched items and return the result. If a "begin", ignore
|
|
; the stack and perform the sequence, returning the result.
|
|
|
|
; |================|
|
|
; |Useful additions|
|
|
; |================|
|
|
|
|
; kleene-star
|
|
; ===========
|
|
|
|
; (* <grammar>)
|
|
|
|
; Match zero or more occurrences of the grammar, and place the list of
|
|
; the results on the stack.
|
|
|
|
; kleene-plus
|
|
; ===========
|
|
|
|
; (* <grammar>)
|
|
|
|
; Match one or more occurrences of the grammar, and place the list of
|
|
; the results on the stack. (If no results than '() is placed on the
|
|
; stack).
|
|
|
|
; kleene?
|
|
; ===========
|
|
|
|
; (?* <grammar>)
|
|
|
|
; Match zero or one occurrences of the grammar, and place the list of
|
|
; the results on the stack, or do nothing.
|
|
|
|
; anything
|
|
; ========
|
|
|
|
; ?
|
|
|
|
; Automatically match anything and put it on the input stack.
|
|
|
|
; rest-of-list
|
|
; ============
|
|
|
|
; __
|
|
|
|
; Automatically match the rest of a list and place it on the input stack.
|
|
; If followed by a lambda-action, it should be a variable arity lambda in order to bind the result of the match of __.
|
|
|
|
; (define number-and-rest
|
|
; (meta-lambda
|
|
; (and number? __ (lambda (num . rest)
|
|
; (cons num (cadr rest))))))
|
|
|
|
; (number-and-rest '(3 cat dog foo)) => '(3 . dog)
|
|
|
|
; |=============|
|
|
; |Weirder stuff|
|
|
; |=============|
|
|
|
|
; end-of-list
|
|
; ===========
|
|
|
|
; ()
|
|
|
|
; Explicitly match the end of list and proceed.
|
|
|
|
; sub-lists
|
|
; =========
|
|
|
|
; (<grammar>)
|
|
|
|
; Ah, trees. Wrapping a parens around a grammar causes meta-lambda to
|
|
; expect a sublist. It itself can contain actions that return
|
|
; values. The sublist is matched and returns results as if you had
|
|
; written a separte meta-lambda for the sublist, and whatever it returns
|
|
; is placed on the stack as a single item.
|
|
|
|
; (define match-lambda-one
|
|
; (meta-lambda
|
|
; (and 'lambda (symbol?) ? (lambda (formals body)
|
|
; `(forms ,@formals)))))
|
|
|
|
; (match-lambda-one '(lambda (a) (foo a (bar b c)))) => '(forms . a)
|
|
|
|
; (define match-lambda
|
|
; (meta-lambda
|
|
; (and 'lambda ((* symbol?)) ? (lambda (formals body)
|
|
; `(forms ,@formals)))))
|
|
|
|
; (match-lambda '(lambda (a b c) (foo a (bar b c)))) => '(forms a b c)
|
|
|
|
; location
|
|
; ========
|
|
|
|
; (unquote <identifier>)
|
|
|
|
; This means match the literal that is bound to the identifier against
|
|
; the next input. Useful for parameterizing.
|
|
|
|
; (define (make-foo-matcher x)
|
|
; (meta-lambda
|
|
; (and 'foo ,x)))
|
|
|
|
; (define foo-3 (make-foo-matcher 3))
|
|
; (define foo-cat (make-foo-matcher 'cat))
|
|
|
|
; (foo-3 '(foo 3)) => #t
|
|
; (foo-3 '(foo 4)) => #f
|
|
|
|
; (foo-cat '(foo cat)) => #t
|
|
; (foo-cat '(foo 3)) => #f
|
|
|
|
; not-a-list
|
|
; ==========
|
|
|
|
; (unquote-splicing <grammar>)
|
|
|
|
; Wrap the input (or the next item in the input) in a list, and then
|
|
; match. This way meta-lambda can match lists or single items.
|
|
|
|
; (define infix
|
|
; (let ((op? (meta-lambda ;doing this for demo purposes. (case ...)
|
|
; ;is better here
|
|
; (or (and ,@'+ (begin +))
|
|
; (and ,@'- (begin -))
|
|
; (and ,@'* (begin *))))))
|
|
; (meta-lambda
|
|
; (or ,@integer?
|
|
; (and infix op? infix (lambda (a op b) (op a b)))))))
|
|
|
|
; (infix '((3 + 4) * ((6 - 3) + 4))) => 49
|
|
|
|
; else
|
|
; ====
|
|
|
|
; (else <procedure>)
|
|
|
|
; If an else-clause is encountered, the rest of the input is immediately
|
|
; accepted, but instead of being accepted on the stack, it is
|
|
; immediately passed to <procedure>, which should be variable arity. The
|
|
; proedure's result, if it returns at all, becomes the result of the
|
|
; whole meta-lambda.
|
|
|
|
; (define infix2
|
|
; (let ((op? (lambda (y)
|
|
; (case y
|
|
; ((+) +)
|
|
; ((-) -)
|
|
; ((*) *)))))
|
|
; (meta-lambda
|
|
; (or ,@integer?
|
|
; (and infix op? infix (lambda (a op b) (op a b)))
|
|
; (else (lambda x (error "bad input" x)))))))
|
|
|
|
; (infix2 '((3 + 4) * ((foo - 3) + 4))) => &error bad input (foo)
|
|
|
|
; |======|
|
|
; |Extras|
|
|
; |======|
|
|
|
|
; meta-lambda-dot grammer -> procedure
|
|
|
|
; Like meta-lambda, but the procedure returned is variable arity as in:
|
|
|
|
; (lambda x ...)
|
|
|
|
; The match procedure is applied to the list "x"
|