unlambda/parser.rkt at master · jkominek/unlambda · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
#lang racket/base

(provide read-term color-lexer)

(define (color-lexer port)
  (define-values (line column position) (port-next-location port))
  (define c (read-char port))

  (cond
   [(eof-object? c)
    (values #f 'eof #f #f #f)]
   [(char-whitespace? c)
    (values #f 'white-space #f position (+ 1 position))]
   [else
    (case c
      [(#\#)
       (read-line port)
       (define-values (l c p) (port-next-location port))
       (values #f 'comment #f position p)]

      [(#\` #\~)
       (values #f 'parenthesis #f position (+ 1 position))]

      [(#\. #\?)
       (if (eof-object? (read-char port))
	   (values #f 'string #f position (+ 1 position))
	   (values #f 'string #f position (+ 2 position)))]

      [else
       (values (string c) 'symbol #f position (+ 1 position))])]))

(define (read-term src [port (current-input-port)])
  (define-values (line column position) (port-next-location port))
  (define c (read-char port))

  (define (decorate sexp span)
    (datum->syntax #f sexp (list src line column position span)))

  (cond
   [(eof-object? c) eof]
   [(char-whitespace? c) (read-term src port)]
   [else
    (case c
      [(#\#)
       (read-line port)
       (read-term src port)]

      [(#\`)
       (let ([a (read-term src port)]
	     [b (read-term src port)])
	 (define-values (l c tail-position) (port-next-location port))
	 (if (or (eof-object? a) (eof-object? b))
	     eof
	     (decorate (list a b) (- tail-position position))))]

      [(#\~)
       (let ([namec (read-char port)]
	     [term (read-term src port)])
	 (define-values (l c tail-position) (port-next-location port))
	 (if (or (eof-object? namec) (eof-object? term))
	     eof
	     (decorate `(%define ,(string->symbol (string namec)) ,term)
		       (- tail-position position))))]

      [(#\.) (let ([c (read-char port)])
	       (if (eof-object? c)
		   eof
		   (decorate `(%dot ,c) 2)))]

      [(#\?) (let ([c (read-char port)])
	       (if (eof-object? c)
		   eof
		   (decorate `(%question ,c) 2)))]

      [else (decorate (string->symbol (string c)) 1)])]))