xmaslang

test.rkt

#lang reader "xmaslang.rkt"
-+
+/|+5++3 1 1 <x +2x>
$->#2<x 1>s 1<i+s i>
+||#5<x ->x<y+$x z 100 <k - z k
 >y> > <x $x a 0 <b +a b> > | -
$ ->#10<x#x>x0<y+x$y z0<y+y z>>
$ ->->#30<x+x1> <x%
    $->#10<a*a$=?->#<foo?=foo*2
    4<bar*+foo bar bar>[-20 15]
    100000>[
      |->#||1 <x+1x> 
              <x+1x> 
        <x |1 <x+1x>>
      <r $r p 0 <q +p q> >
    ]<i+100i> <x>x100>
    acc 0 < item + acc item > >
    merry-xmas1<b+merry-xmas b>
  x>
a-c0<m+m a-c>
<x*113x>
|||*|||1<x 1><x+|1<x 1>x><x*
||1<x 1><x+|1<x 1>x>x> 
|||1<x 1><x+|1<x 1>x><x+
||1<x 1><x+||1<x 1><x+
|1<x 1>x>x>x><x+
|||1<x 1><x+|1<x 1>x><x+
||1<x 1><x+||1<x 1><x+
|1<x 1>x>x>x>x><x+|*
|||1<x 1><x+|1<x 1>x><x*
||1<x 1><x+|1<x 1>x>x> 
|||1<x 1><x+|1<x 1>x><x+
||1<x 1><x+||1<x 1><x+
|1<x 1>x>x>x><x+|||1<x 1><x+
|1<x 1>x><x+||1<x 1><x+
||1<x 1><x+
|1<x 1>x>x>x>x>x><x+||*
|||1<x 1><x+|1<x 1>x><x*
||1<x 1><x+|1<x 1>x>x> 
|||1<x 1><x+|1<x 1>x><x+
||1<x 1><x+||1<x 1><x+
|1<x 1>x>x>x><x+|||1<x 1><x+
|1<x 1>x><x+||1<x 1><x+
||1<x 1><x+|1<x 1>x>x>x>x><x+
|*|||1<x 1><x+|1<x 1>x><x*
||1<x 1><x+|1<x 1>x>x> 
|||1<x 1><x+|1<x 1>x><x+
||1<x 1><x+||1<x 1><x+
|1<x 1>x>x>x><x+|||1<x 1><x+
|1<x 1>x><x+||1<x 1><x+
||1<x 1><x+|1<x 1>x>x>x>x>x>x>
||#80 <r =?r <e > e 80>>
      <s $s acc 0 <i + a i>>

xmaslang.rkt

#lang racket
(require parser-tools/lex
         (prefix-in : parser-tools/lex-sre))

(provide (rename-out (xmas-read-syntax read-syntax)
                     (xmas-read read)))

(define marker (make-syntax-introducer))

(define (tokenize ip)
  (port-count-lines! ip)
  (define my-lexer
    (lexer-src-pos
     [(eof) 'eof]
     [(:or #\tab #\space #\newline) 'space]
     ["<" 'fstart]
     ["[" 'argstart]
     ["]" 'argend]
     [">" 'gt]
     ["=" 'equal]
     ["?" 'ifelse]
     ["#" 'list]
     ["|" 'pipe]
     ["->" 'map]
     ["=?" 'filter]
     ["$" 'reduce]
     ["+" 'plus]
     ["-" 'minus]
     ["*" 'mul]
     ["/" 'div]
     ["%" 'rem]
     [(:+ (:or (:/ #\a #\z) (:/ #\A #\Z) #\-)) `(id ,(string->symbol lexeme))]
     [(:+ (:/ #\0 #\9)) `(num ,(string->number lexeme))]))
  (define (next-token) (my-lexer ip))
  next-token)

(define (read-string s (src #f))
  (read-stream (open-input-string s) src))

(define (read-stream s (src #f))
  (define next (tokenize s))
  (let loop ([token (next)])
    (define a (position-token-token token))
    (cond [(eq? a 'eof) (syntax/loc (token->syntax token src) ())]
          [(eq? a 'space) (loop (next))]
          [else (with-syntax ([stxa (token->syntax token src)]
                              [stxb (loop (next))])
                  #'(stxa . stxb))])))

(define dummy-stx #'e)
(define (token->syntax t src)
  (match t
    ((position-token s (position start-pos line column) (position end-pos _ _))
     (marker (datum->syntax dummy-stx s (list src line column start-pos (- end-pos start-pos)))))))

(define (scar stx)
  (syntax-case stx ()
    ((a . d) #'a)))

(define (scdr stx)
  (syntax-case stx ()
    ((a . d) #'d)))

(define-syntax with-next
  (syntax-rules ()
    ((_ (stx rstx env) exp ...)
     (let ([rstx stx])
       exp ...))
    ((_ ((#:id x) xs ... stx rstx env) exp ...)
     (syntax-case (scar stx) (id)
       ((id x) (with-next (xs ... (scdr stx) rstx env) exp ...))))
    ((_ (x xs ... stx rstx env) exp ...)
     (match-let ([`(,tx ,rest) (parse-stx stx env)])
       (with-syntax ([x tx])
         (with-next (xs ... rest rstx env) exp ...))))))

(define (parse-stx stx (env (set)))
  (match-define `(,x ,r) (parse-stx-helper stx env))
  (let loop ([x x]
             [r1 r])
    (syntax-case r1 (argstart)
      ((argstart . r2)
       (with-syntax ([fun x])
         (with-next (arg #'r2 r3 env)
           (loop #'(fun arg)
                 (syntax-case r3 (argend)
                   ((argend . r4) #'r4)
                   ((x . _) (raise (exn:fail:syntax
                                    "bad syntax"
                                    (current-continuation-marks)
                                    `(,#'x)))))))))
      (_ `(,x ,r1)))))

(define (parse-stx-helper stx env)
  (define-syntax-rule (res p r)
    (list (syntax/loc (scar stx) p) r))
  (syntax-case (scar stx) (fstart argstart argend gt equal ifelse list pipe map filter reduce plus minus mul div rem num id)
    ((num n) `(,#'n ,(scdr stx)))
    ((id i) (if (set-member? env (syntax->datum #'i))
                (res i (scdr stx))
                (raise (exn:fail:syntax:unbound
                        "unbound variable"
                        (current-continuation-marks)
                        `(,#'i)))))
    (ifelse
     (with-next (a b c (scdr stx) r env)
       (res (if a b c) r)))
    (reduce
     (with-next (l (#:id acc) init (scdr stx) r1 env)
       (with-next (fun r1 r2 (set-add env (syntax->datum #'acc)))
         (res (for/fold
                  ((acc init))
                ((el l))
                (fun el))
             r2))))
    (list
     (with-next (a (scdr stx) r env)
       (res (stream->list (in-range (+ a 1))) r)))
    (plus
     (with-next (a b (scdr stx) r env)
       (res (+ a b) r)))
    (minus
     (with-next (a b (scdr stx) r env)
       (res (- a b) r)))
    (div
     (with-next (a b (scdr stx) r env)
       (res (quotient a b) r)))
    (rem
     (with-next (a b (scdr stx) r env)
       (res (remainder a b) r)))
    (mul
     (with-next (a b (scdr stx) r env)
       (res (* a b) r)))
    (pipe
     (with-next (a f (scdr stx) r env)
       (res (f a) r)))
    (map
     (with-next (l f (scdr stx) r env)
       (res (map f l) r)))
    (filter
     (with-next (l p (scdr stx) r env)
       (res (filter p l) r)))
    (gt
     (with-next (a b (scdr stx) r env)
       (res (> a b) r)))
    (equal
     (with-next (a b (scdr stx) r env)
       (res (= a b) r)))
    (fstart
     (with-next ((#:id p) (scdr stx) r1 env)
       (with-next (x r1 r2 (set-add env (syntax->datum #'p)))
         (syntax-case r2 (gt)
           ((gt . r3) (res (λ (p) x) #'r3))
           ((x . _) (raise (exn:fail:syntax
                            "bad syntax"
                            (current-continuation-marks)
                            `(,#'x))))))))))

(define (xmas-read-syntax src in)
  (with-syntax ([stx (car (parse-stx (read-stream in src)))])
    #'(module xmas racket
        stx)))

(define (xmas-read in)
  (xmas-read-syntax #f in))