rendered paste body;; NOTES: a token is a (list symbol symbol) e.g. (list 'NUMBER 3.14)
;; a transition is a (list symbol (char -> boolean) symbol) e.g. (list 'START char-numeric? 'NUMBER)
;; a s-expr is a quoted scheme expression
;; CONTRACT: parse: string -> (listof s-expr)
;; PURPOSE: Transform a string into a list of sexpr
;; EFFECTS: External: None
;; Internal: None
(define parse
(lambda (str)
(local
[;; CONTRACT: tokenize: string -> (listof token)
;; PURPOSE: Consume a string and transform it into a list of tokens
(define tokenize
(lambda (str)
(local
[(define next-token ; next-token: (listof char)
(lambda (charlst)
(local
[;;;;;; char test functions ;;;;;;
(define char-cmp ; char-cmp: char -> (char -> boolean)
(lambda (tst)
(lambda (ch) (char=? tst ch))))
(define char-cmp-or ; char-cmp-or: (char -> boolean) (char -> boolean) -> (char->boolean)
(lambda (cmp1 cmp2)
(lambda (ch) (or (cmp1 ch) (cmp2 ch)))))
(define char-paren? ; char-paren?: char -> boolean
(lambda (ch)
(ormap (lambda (cmp) (char=? cmp ch)) (list #\( #\) #\[ #\]))))
(define char-name? ; char-name?: char -> boolean
(lambda (ch)
(not (or (ormap (lambda (cmp) (char=? cmp ch))
(list #\" #\, #\' #\` #\| #\; #\#))
(char-whitespace? ch)
(char-paren? ch)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define translist (list
; ambiguous
(list 'START (char-cmp #\-) 'MINUS)
(list 'START (char-cmp #\.) 'PERIOD)
; symbols
(list 'START (char-cmp #\') 'SYMBOL)
(list 'SYMBOL char? 'FINISHED)
; identifiers
(list 'START (lambda (ch) (and (char-name? ch) (not (char-numeric? ch)))) 'IDENTIFIER)
(list 'IDENTIFIER char-name? 'IDENTIFIER)
(list 'IDENTIFIER (char-cmp-or char-whitespace? char-paren?) 'FINISHED)
(list 'MINUS (lambda (ch) (and (char-name? ch) (not (char-numeric? ch)))) 'IDENTIFIER)
; numbers
(list 'START char-numeric? 'INTEGER)
(list 'INTEGER char-numeric? 'INTEGER)
(list 'INTEGER (char-cmp-or char-whitespace? char-paren?) 'FINISHED)
(list 'INTEGER (char-cmp #\.) 'DECIMAL)
(list 'DECIMAL char-numeric? ' DECIMAL)
(list 'DECIMAL (char-cmp-or char-whitespace? char-paren?) 'FINISHED)
(list 'MINUS char-numeric? 'INTEGER)
(list 'INTEGER (char-cmp #\/) 'FRACTION)
(list 'FRACTION char-numeric? 'FRACTION)
(list 'FRACTION (char-cmp-or char-whitespace? char-paren?) 'FINISHED)
; complex numbers go here
; parents
(list 'START char-paren? 'PAREN)
(list 'PAREN char? 'FINISHED)
; whitespace
(list 'START char-whitespace? 'WHITESPACE)
(list 'WHITESPACE char-whitespace? 'WHITESPACE)
(list 'WHITESPACE (lambda (ch) (not (char-whitespace? ch))) 'FINISHED)
))
(define getnextstate ; getnextstate: character symbol (listof transition) -> symbol
(lambda (ch state tlst)
(cond
[(empty? tlst) false]
[(and (symbol=? (caar tlst) state) ((cadr (car tlst)) ch)) (caddr (car tlst))]
[else
(getnextstate ch state (cdr tlst))])))
(define next-token ; next-token: (listof char) symbol (listof char) -> (list symbol (list symbol symbol))
(lambda (charlst state acc)
(local
[(define next-state
(cond
[(empty? charlst) 'FINISHED]
[else (getnextstate (car charlst) state translist)]))]
(cond
[(boolean? next-state)
(error 'next-token
(string-append "parse error, no state transition for state " (symbol->string state)
" with character " (list->string (list (car charlst)))
". Accumulator = \"" (list->string (reverse acc)) "\""))]
[(symbol=? next-state 'FINISHED) (list charlst state (string->symbol (list->string (reverse acc))))]
[else (next-token (cdr charlst) next-state (cons (car charlst) acc))]))))]
(next-token charlst 'START empty))))
(define clean-token ; clean-token (list symbol symbol) -> (list symbol symbol)
(lambda (token)
(cond
;
[(or (symbol=? 'INTEGER (car token)) (symbol=? 'FRACTION (car token)) (symbol=? 'DECIMAL (car token)))
(list (car token) (string->number (symbol->string (cadr token))))]
[else token])))
(define tokenize ; tokenize: (listof char) (listof token) -> (listof token)
(lambda (chlist acc)
(cond
[(empty? chlist) (reverse acc)]
[else ((lambda (x) (tokenize (car x) (cons (clean-token (cdr x)) acc))) (next-token chlist))])))] ; excuse the funkiness
(tokenize (string->list str) empty))))
;; CONTRACT: build-sexpr: (listof token) s-expr union('|)| '||]|) (continuation-lambda)
;; PURPOSE: Consume a list of tokens, keep an accumulator of s-exprs, remember which type of paren is active (circle or
;; square) and keep a continuation lambda
(define build-sexpr
(lambda (tokens acc endparen cont)
(local
[(define type (cond [(empty? tokens) 'oops] [else (caar tokens)]))
(define match-delim
(lambda (p)
(cond
[(symbol=? p '|(|) '|)|]
[(symbol=? p '|[|) '|]|])))]
(cond
[(empty? tokens)
(cond
[(symbol=? endparen 'NONE) (cont (reverse acc))]
[else (error 'build-sexpr (string-append "Unmatched " (symbol->string endparen)))])]
[(symbol=? 'PAREN type)
(cond
[(or (symbol=? '|(| (cadar tokens)) (symbol=? '|[| (cadar tokens)))
(build-sexpr (cdr tokens) empty (match-delim (cadar tokens))
(lambda (tokens subexpr) (build-sexpr tokens (cons subexpr acc) endparen cont)))]
[(symbol=? endparen (cadar tokens)) (cont (cdr tokens) (reverse acc))]
[else (error 'build-sexpr (string-append "Unexpected " (symbol->string (cadar tokens))))])]
[(symbol=? 'WHITESPACE type) (build-sexpr (cdr tokens) acc endparen cont)] ; ignore whitespace
[else (build-sexpr (cdr tokens) (cons (cadar tokens) acc) endparen cont)]
))))]
(build-sexpr (tokenize str) empty 'NONE (lambda (x) x)))))
;; CONTRACT: eval: expr env -> expr
;; PURPOSE: Reduce an expression as far as possible
(define eval
(lambda (expr env)
(local
[(define zip ; list list -> assoclist
(lambda (L1 L2)
(local
[(define zip
(lambda (L1 L2 acc)
(cond
[(empty? L2) (reverse acc)]
[else (zip (cdr L1) (cdr L2) (cons (list (car L1) (car L2)) acc))])))]
(zip L1 L2 empty))))
(define lookup ; lookup: symbol env -> expr
(lambda (sym env)
(local
[(define ans (assq sym env))]
(cond
[(boolean? ans) (error 'lookup (format "symbol undefined: ~a" (symbol->string sym)))]
[else (cadr ans)]))))
(define lookup-prm ; lookup-prm: symbol -> prm
(lambda (sym)
(local
[(define prm-ops `((+ ,+) (- ,-) (* ,*) (cons ,cons) (car ,car) (cdr ,cdr) (empty ,empty) (empty? ,empty?)))
(define ans (assq sym prm-ops))]
(cond
[(boolean? ans) #f]
[else (cadr ans)]))))
(define exprsubs
(lambda (expr env)
(local
[(define exprsubs
(lambda (expr env acc)
(cond
[(empty? expr) (reverse acc)]
[(and (cons? (car expr)) (cons? (car expr))) (exprsubs (cdr expr) env (cons (exprsubs (car expr) env empty) acc))]
[else
(local
[(define subs
(cond
[(boolean? (lookup-prm (car expr))) (lookup (car expr) env)]
[else (lookup-prm (car expr))]))]
(exprsubs (cdr expr) env (cons subs acc)))])))]
(exprsubs expr env empty))))
(define getlocaldefs
(lambda (defs) ...))]
(cond
[(empty? expr) (error 'eval "expected a special form or primative name after an open parenthesis, but nothing's there")]
[(number? expr) expr]
[(symbol? expr)
(cond
[(boolean? (lookup-prm expr)) (lookup expr env)]
[else (lookup-prm expr)])]
[(and (cons? expr) (cons? (car expr))) (eval (caddr (car expr)) (zip (cadar expr) (map (lambda (x) (eval x env)) (cdr expr))))]
[(cons? expr)
(cond
;[(number? (car expr)) (error 'eval (format "expected procedure, given ~a; other arguments were: ~a" (car expr) (cdr expr)))]
[(symbol=? 'cond (car expr)) ...]
[(symbol=? 'local (car expr)) (eval (caddr expr) (append (getlocaldefs (cadr expr)) env))] ; a local expr - (local <listof definitions> expr)
[(symbol=? 'lambda (car expr)) (list 'lambda (cadr expr) (exprsubs (caddr expr) (append (zip (cadr expr) (cadr expr)) env)))] ; a lambda expr
[(symbol=? 'quote (car expr)) (cadr expr)] ; a symbol
[else (cond ; (<func> <arg1> ... <argn>) - function application
[(boolean? (lookup-prm (car expr))) (eval (caddr expr) (zip (cadr expr) (eval (car expr) env)) (map (lambda (x) (eval x env)) (cdr expr)))]
[else (apply (lookup-prm (car expr)) (map (lambda (x) (eval x env)) (cdr expr)))]
)])]
[else (error 'eval "unexpected syntax")]))))