159 lines
7.5 KiB
Scheme
159 lines
7.5 KiB
Scheme
;*---------------------------------------------------------------------*/
|
|
;* Copyright (c) 1997 by Manuel Serrano. All rights reserved. */
|
|
;* */
|
|
;* ,--^, */
|
|
;* _ ___/ /|/ */
|
|
;* ,;'( )__, ) ' */
|
|
;* ;; // L__. */
|
|
;* ' \ / ' */
|
|
;* ^ ^ */
|
|
;* */
|
|
;* */
|
|
;* This program is distributed in the hope that it will be useful. */
|
|
;* Use and copying of this software and preparation of derivative */
|
|
;* works based upon this software are permitted, so long as the */
|
|
;* following conditions are met: */
|
|
;* o credit to the authors is acknowledged following */
|
|
;* current academic behaviour */
|
|
;* o no fees or compensation are charged for use, copies, */
|
|
;* or access to this software */
|
|
;* o this copyright notice is included intact. */
|
|
;* This software is made available AS IS, and no warranty is made */
|
|
;* about the software or its performance. */
|
|
;* */
|
|
;* Bug descriptions, use reports, comments or suggestions are */
|
|
;* welcome Send them to */
|
|
;* Manuel Serrano -- Manuel.Serrano@cui.unige.ch */
|
|
;*---------------------------------------------------------------------*/
|
|
;;;--------------------------------------------------------------------*/
|
|
;;; geffroy/Match3.0/expand.scm ... */
|
|
;;; */
|
|
;;; Author : Jean-Marie Geffroy */
|
|
;;; Creation : Wed Mar 10 13:21:53 1993 */
|
|
;;; Last change : Tue Jun 8 10:41:34 1993 (geffroy) */
|
|
;;; */
|
|
;;; An expanser for the MATCH-LAMBDA and MATCH-CASE forms */
|
|
;;;--------------------------------------------------------------------*/
|
|
|
|
|
|
;;;--------------------------------------------------------------------*/
|
|
;;; (match-lambda */
|
|
;;; (f1 e1 e2 ...) */
|
|
;;; (f2 e21 ...) */
|
|
;;; (else e ...)) */
|
|
;;; the else clause being optional */
|
|
;;; expands into (lambda (e) ...) */
|
|
;;; */
|
|
;;; (match-case <exp> */
|
|
;;; (f1 e1 e2 ...) */
|
|
;;; (f2 e21 ...) */
|
|
;;; (else e ...)) */
|
|
;;; expands into ((lambda (e) ...) e) */
|
|
;;;--------------------------------------------------------------------*/
|
|
|
|
(module __match_expand
|
|
|
|
(export (expand-match-case exp)
|
|
(expand-match-lambda exp))
|
|
|
|
(import (__error "Llib/error.scm")
|
|
(__match_compiler "Match/compiler.scm")
|
|
(__match_descriptions "Match/descr.scm")
|
|
(__match_normalize "Match/normalize.scm")
|
|
(__match_s2cfun "Match/s2cfun.scm"))
|
|
|
|
(use (__type "Llib/type.scm")
|
|
(__bigloo "Llib/bigloo.scm")
|
|
(__tvector "Llib/tvector.scm")
|
|
(__structure "Llib/struct.scm")
|
|
(__tvector "Llib/tvector.scm")
|
|
(__rgc "Rgc/runtime.scm")
|
|
(__r4_numbers_6_5 "Ieee/number.scm")
|
|
(__r4_numbers_6_5_fixnum "Ieee/fixnum.scm")
|
|
(__r4_numbers_6_5_flonum "Ieee/flonum.scm")
|
|
(__r4_characters_6_6 "Ieee/char.scm")
|
|
(__r4_equivalence_6_2 "Ieee/equiv.scm")
|
|
(__r4_booleans_6_1 "Ieee/boolean.scm")
|
|
(__r4_symbols_6_4 "Ieee/symbol.scm")
|
|
(__r4_strings_6_7 "Ieee/string.scm")
|
|
(__r4_pairs_and_lists_6_3 "Ieee/pair-list.scm")
|
|
(__r4_input_6_10_2 "Ieee/input.scm")
|
|
(__r4_control_features_6_9 "Ieee/control.scm")
|
|
(__r4_vectors_6_8 "Ieee/vector.scm")
|
|
(__r4_ports_6_10_1 "Ieee/port.scm")
|
|
(__r4_output_6_10_3 "Ieee/output.scm")
|
|
(__evenv "Eval/evenv.scm")))
|
|
|
|
;;;--------------------------------------------------------------------*/
|
|
;;; Technical note: the clauses->pattern function returns two */
|
|
;;; results: */
|
|
;;; - the normalized pattern, (tagged-or f1 tag1 (t-or ...)) */
|
|
;;; - an environment tag -> action* */
|
|
;;; and is therefore written in CPS. */
|
|
;;;--------------------------------------------------------------------*/
|
|
(define (expand-match-lambda exp)
|
|
(labels ((clauses->pattern
|
|
(clauses k)
|
|
(if (null? clauses)
|
|
(k '(not (any)) *the-empty-env*)
|
|
(let ((pattern (caar clauses))
|
|
(actions (cdar clauses))
|
|
(rest (cdr clauses)))
|
|
(let ((tag (jim-gensym "TAG-")))
|
|
(if (eq? pattern 'else)
|
|
(k `(tagged-or (any) ,tag (not (any)))
|
|
(extend *the-empty-env* tag actions))
|
|
(clauses->pattern
|
|
rest
|
|
(lambda (pat env)
|
|
(k `(tagged-or ,(normalize-pattern pattern)
|
|
,tag
|
|
,pat)
|
|
(extend env tag actions))))))))))
|
|
;;; (match-case clauses */
|
|
;;; (() (k '(not (any)) *the-empty-env*)) */
|
|
;;; (( (?pattern . ?actions) . ?rest ) */
|
|
;;; (let ((tag (jim-gensym "TAG-"))) */
|
|
;;; (if (eq? pattern 'else) */
|
|
;;; (k `(tagged-or (any) ,tag (not (any))) */
|
|
;;; (extend *the-empty-env* tag actions)) */
|
|
;;; (clauses->pattern */
|
|
;;; rest */
|
|
;;; (lambda (pat env) */
|
|
;;; (k `(tagged-or ,(normalize-pattern pattern) */
|
|
;;; ,tag */
|
|
;;; ,pat) */
|
|
;;; (extend env tag actions)))))))))) */
|
|
(clauses->pattern
|
|
(cdr exp)
|
|
(lambda (pat env)
|
|
(let ((compiled-pat (pcompile pat))
|
|
(prototypes (fetch-prototypes pat)) )
|
|
;; We build a (labels ((tag1 (x ...) actions1)) ...)
|
|
;; You may change it to build a letrec
|
|
`(labels
|
|
(,@(map
|
|
(lambda (prototype)
|
|
(cons (car prototype)
|
|
(cons (cadr prototype)
|
|
(cdr (assq (car prototype)
|
|
env)))))
|
|
prototypes))
|
|
,compiled-pat))))))
|
|
|
|
(define (fetch-prototypes pat)
|
|
(if (memq (car pat) '(t-or tagged-or))
|
|
(cons `(,(caddr pat) ,(pattern-variables (cadr pat)))
|
|
(fetch-prototypes (cadddr pat)))
|
|
'()))
|
|
|
|
(define (expand-match-case exp)
|
|
(list (expand-match-lambda `(match-lambda . ,(cddr exp)))
|
|
(cadr exp)))
|
|
|
|
(define (extend env pt im)
|
|
(cons (cons pt im) env))
|
|
|
|
(define *the-empty-env* '())
|
|
|