Created
April 19, 2023 17:45
-
-
Save lubaochuan/ac140653880b7959fcbced85d58b3562 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
#lang racket | |
;; This is a new version of pmatch (August 8, 2012). | |
;; It has two important new features: | |
;; 1. It allows for a name to be given to the pmatch if an error ensues. | |
;; 2. A line from the specification has been removed. (see below). Without | |
;; that line removed, it was impossible for a pattern to be (quote ,x), | |
;; which might be worth having especially when we write an interpreter | |
;; for Scheme, which includes quote as a language form. | |
;;; Code written by Oleg Kiselyov | |
;; (http://pobox.com/~oleg/ftp/) | |
;;; | |
;;; Taken from leanTAP.scm | |
;;; http://kanren.cvs.sourceforge.net/kanren/kanren/mini/leanTAP.scm?view=log | |
; A simple linear pattern matcher | |
; It is efficient (generates code at macro-expansion time) and simple: | |
; it should work on any R5RS (and R6RS) Scheme system. | |
; (pmatch exp <clause> ...[<else-clause>]) | |
; <clause> ::= (<pattern> <guard> exp ...) | |
; <else-clause> ::= (else exp ...) | |
; <guard> ::= boolean exp | () | |
; <pattern> :: = | |
; ,var -- matches always and binds the var | |
; pattern must be linear! No check is done | |
; _ -- matches always | |
; 'exp -- comparison with exp (using equal?) REMOVED (August 8, 2012) | |
; exp -- comparison with exp (using equal?) | |
; (<pattern1> <pattern2> ...) -- matches the list of patterns | |
; (<pattern1> . <pattern2>) -- ditto | |
; () -- matches the empty list | |
(define-syntax pmatch | |
(syntax-rules (else guard) | |
((_ v (e ...) ...) | |
(pmatch-aux #f v (e ...) ...)) | |
((_ v name (e ...) ...) | |
(pmatch-aux name v (e ...) ...)))) | |
(define-syntax pmatch-aux | |
(syntax-rules (else guard) | |
((_ name (rator rand ...) cs ...) | |
(let ((v (rator rand ...))) | |
(pmatch-aux name v cs ...))) | |
((_ name v) | |
(begin | |
(if 'name | |
(printf "pmatch ~s failed\n~s\n" 'name v) | |
(printf "pmatch failed\n ~s\n" v)) | |
(error 'pmatch "match failed"))) | |
((_ name v (else e0 e ...)) (begin e0 e ...)) | |
((_ name v (pat (guard g ...) e0 e ...) cs ...) | |
(let ((fk (lambda () (pmatch-aux name v cs ...)))) | |
(ppat v pat (if (and g ...) (begin e0 e ...) (fk)) (fk)))) | |
((_ name v (pat e0 e ...) cs ...) | |
(let ((fk (lambda () (pmatch-aux name v cs ...)))) | |
(ppat v pat (begin e0 e ...) (fk)))))) | |
(define-syntax ppat | |
(syntax-rules (? comma unquote) | |
((_ v ? kt kf) kt) | |
((_ v () kt kf) (if (null? v) kt kf)) | |
; ((_ v (quote lit) kt kf) (if (equal? v (quote lit)) kt kf)) | |
((_ v (unquote var) kt kf) (let ((var v)) kt)) | |
((_ v (x . y) kt kf) | |
(if (pair? v) | |
(let ((vx (car v)) (vy (cdr v))) | |
(ppat vx x (ppat vy y kt kf) kf)) | |
kf)) | |
((_ v lit kt kf) (if (equal? v (quote lit)) kt kf)))) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment