parser.scm

   1 ; Work in progress...\r
   2 \r
   3 (define (one-of string)\r
   4   (map list (string->list string)))\r
   5 \r
   6 (define (match pattern x)\r
   7   (define (single-match pat x)\r
   8     (cond ((procedure? pat) (pat x))\r
   9           ((char?      pat) (and (char=? pat (car x))\r
  10                                  (cons (car x) (cdr x))))))\r
  11   (let loop ((acc (list)) (pattern pattern) (x x))\r
  12     (if (null? pattern)\r
  13         (cons (reverse acc) x)\r
  14         (let ((result (single-match (car pattern) x)))\r
  15           (and result\r
  16                (loop (cons (car result) acc) (cdr pattern) (cdr result)))))))\r
  17 \r
  18 (define-syntax do-it\r
  19   (syntax-rules ()\r
  20     ((_ x) (car x))\r
  21     ((_ x f) (apply f x))))\r
  22 \r
  23 (define-syntax make-parser\r
  24   (syntax-rules ()\r
  25     ((_ start (rulename (pattern ...) . function) ...)\r
  26      (lambda (string)\r
  27        (letrec\r
  28            ((rulename\r
  29              (lambda (x)\r
  30                ((lambda (y) (cons (do-it (car y) . function) (cdr y)))\r
  31                 (cond\r
  32                   ((match (list . pattern) x))\r
  33                   ...))))\r
  34             ...)\r
  35          (start (string->list string)))))))\r
  36 \r
  37 (define test-parser\r
  38   (make-parser\r
  39    one\r
  40    (one   ((#\1 two three)) list)\r
  41    (two   ((#\2)) (lambda (x) "SHIT"))\r
  42    (three ((#\3)))))\r
  43 \r
  44 (define (showcons x)\r
  45   (display "(")\r
  46   (write (car x))\r
  47   (display " . ")\r
  48   (write (cdr x))\r
  49   (display ")"))\r
  50 \r
  51 (showcons (test-parser "123a"))