match.scm

Scheme跨平台编译器

            (if (and (pair? (cdr args)) (null? (cddr args)))
                ((lambda () `(begin (define ,@args))))
                (g209))
            (if (and (pair? (cdr args)) (null? (cddr args)))
                ((lambda (pat exp)
                   ((caddr ##match#expanders)
                    pat
                    exp
                    `(match-define ,@args)))
                 (car args)
                 (cadr args))
                (g209)))
        (g209))))


;;; Support code

(define ##match#syntax-err
  (lambda (obj msg) (##sys#signal-hook #:syntax-error msg obj)))
(define ##match#set-error (lambda (v) (set! ##sys#match-error v)))
(define ##match#error-control #:error)
(define ##match#set-error-control
  (lambda (v) (set! ##match#error-control v)))
(define ##match#disjoint-predicates
  (cons 'null
        '(pair?
           symbol?
           boolean?
           number?
           string?
           char?
           procedure?
           vector?)))
(define ##match#expanders
  (letrec ((genmatch (lambda (x clauses match-expr)
                       (let* ((length>= (gensym))
                              (eb-errf (error-maker match-expr))
                              (blist (car eb-errf))
                              (plist (map (lambda (c)
                                            (let* ((x (bound
                                                        (validate-pattern
                                                          (car c))))
                                                   (p (car x))
                                                   (bv (cadr x))
                                                   (bindings (caddr x))
                                                   (code (gensym))
                                                   (fail (and (pair?
                                                                (cdr c))
                                                              (pair?
                                                                (cadr c))
                                                              (eq? (caadr
                                                                     c)
                                                                   '=>)
                                                              (symbol?
                                                                (cadadr c))
                                                              (pair?
                                                                (cdadr c))
                                                              (null?
                                                                (cddadr c))
                                                              (pair?
                                                                (cddr c))
                                                              (cadadr c)))
                                                   (bv2 (if fail
                                                            (cons fail bv)
                                                            bv))
                                                   (body (if fail
                                                             (cddr c)
                                                             (cdr c))))
                                              (set! blist
                                                (cons `(,code
                                                         (lambda ,bv2
                                                           ,@body))
                                                      (append
                                                        bindings
                                                        blist)))
                                              (list p
                                                    code
                                                    bv
                                                    (and fail (gensym))
                                                    #f)))
                                          clauses))
                              (code (gen x
                                         '()
                                         plist
                                         (cdr eb-errf)
                                         length>=
                                         (gensym))))
                         (unreachable plist match-expr)
                         (inline-let
                           `(let ((,length>= (lambda (n)
                                               (lambda (l)
                                                 (>= (length l) n))))
                                  ,@blist)
                              ,code)))))
           (genletrec (lambda (pat exp body match-expr)
                        (let* ((length>= (gensym))
                               (eb-errf (error-maker match-expr))
                               (x (bound (validate-pattern pat)))
                               (p (car x))
                               (bv (cadr x))
                               (bindings (caddr x))
                               (code (gensym))
                               (plist (list (list p code bv #f #f)))
                               (x (gensym))
                               (m (gen x
                                       '()
                                       plist
                                       (cdr eb-errf)
                                       length>=
                                       (gensym)))
                               (gs (map (lambda (_) (gensym)) bv)))
                          (unreachable plist match-expr)
                          `(letrec ((,length>= (lambda (n)
                                                 (lambda (l)
                                                   (>= (length l) n))))
                                    ,@(map (lambda (v) `(,v #f)) bv)
                                    (,x ,exp)
                                    (,code (lambda ,gs
                                             ,@(map (lambda (v g)
                                                      `(set! ,v ,g))
                                                    bv
                                                    gs)
                                             ,@body))
                                    ,@bindings
                                    ,@(car eb-errf))
                             ,m))))
           (gendefine (lambda (pat exp match-expr)
                        (let* ((length>= (gensym))
                               (eb-errf (error-maker match-expr))
                               (x (bound (validate-pattern pat)))
                               (p (car x))
                               (bv (cadr x))
                               (bindings (caddr x))
                               (code (gensym))
                               (plist (list (list p code bv #f #f)))
                               (x (gensym))
                               (m (gen x
                                       '()
                                       plist
                                       (cdr eb-errf)
                                       length>=
                                       (gensym)))
                               (gs (map (lambda (_) (gensym)) bv)))
                          (unreachable plist match-expr)
                          `(begin ,@(map (lambda (v) `(define ,v #f)) bv)
                                  ,(inline-let
                                     `(let ((,length>= (lambda (n)
                                                         (lambda (l)
                                                           (>= (length l)
                                                               n))))
                                            (,x ,exp)
                                            (,code (lambda ,gs
                                                     ,@(map (lambda (v g)
                                                              `(set! ,v
                                                                 ,g))
                                                            bv
                                                            gs)
                                                     (##sys#void)))
                                            ,@bindings
                                            ,@(car eb-errf))
                                        ,m))))))
           (pattern-var? (lambda (x)
                           (and (symbol? x)
                                (not (dot-dot-k? x))
                                (not (memq x
                                           '(quasiquote
                                              quote
                                              unquote
                                              unquote-splicing
                                              ?
                                              _
                                              $
                                              =
                                              and
                                              or
                                              not
                                              set!
                                              get!
                                              ...
                                              ___))))))
           (dot-dot-k? (lambda (s)
                         (and (symbol? s)
                              (if (memq s '(... ___))
                                  0
                                  (let* ((s (symbol->string s))
                                         (n (string-length s)))
                                    (and (<= 3 n)
                                         (memq (string-ref s 0) '(#\. #\_))
                                         (memq (string-ref s 1) '(#\. #\_))
                                         (##match#every
                                           char-numeric?
                                           (string->list
                                             (substring s 2 n)))
                                         (string->number
                                           (substring s 2 n))))))))
           (error-maker (lambda (match-expr)
                          (cond
                            ((eq? ##match#error-control '#:unspecified) (cons '()
                                                                          (lambda (x) '(##sys#void))))
                            ((memq ##match#error-control '(#:error #:fail)) (cons '()
                                                                            (lambda (x)
                                                                              `(##sys#match-error
                                                                                 ,x))))
                            ((eq? ##match#error-control '#:match) (let ((errf (gensym))
                                                                    (arg (gensym)))
                                                                (cons `((,errf
                                                                          (lambda (,arg)
                                                                            (##sys#match-error
                                                                              ,arg
                                                                              ',match-expr))))
                                                                      (lambda (x)
                                                                        `(,errf
                                                                           ,x)))))
                            (else (##match#syntax-err