Creating a custom #lang language

lang__reader.rkt

#lang s-exp syntax/module-reader
(planet rodolfo/ratematica/language)
#:read ratematica-read
#:read-syntax ratematica-read-syntax
 
(require (prefix-in ratematica- "../parser.rkt"))

language.rkt

#lang racket

(require "semantics.rkt")

(provide ; from semantics
         plus
         minus
         times
         divided-by
         
         ; defined here
         equals
         value-of
         question
         bang
         (rename-out [my-module-begin #%module-begin])
         
         ; others
         #%datum
         )

;; The environment of this language
(define current-env (make-parameter (new-env)))

;; Every module in this language will make sure that it
;; uses a fresh environment.
(define-syntax-rule (my-module-begin body ...)
  (#%plain-module-begin
    (parameterize ([current-env (new-env)])
       body ...)))

(define-syntax-rule (equals name value)
  (assign (current-env) 'name value))

(define-syntax-rule (value-of name)
  (resolve (current-env) 'name))

(define-syntax-rule (question)
  (read-from-stdin))

(define-syntax-rule (bang value)
  (write-to-stdout value))

lexer.rkt

#lang racket

;; A lexer for Ratemática.


;; Import the lexer generators.
(require parser-tools/lex
         (prefix-in : parser-tools/lex-sre))

(provide value-tokens
         op-tokens
         ratemática-lexer)

(define-tokens value-tokens (NUM VAR STR))
(define-empty-tokens op-tokens (newline = OP CP + - * / EOF NEG ! ?))

(define-lex-abbrevs
 (lower-letter (:/ "a" "z"))
 (upper-letter (:/ #\A #\Z))
 (digit (:/ "0" "9")))
 
(define ratemática-lexer
  (lexer-src-pos
   [(eof) 'EOF]
   ;; recursively call the lexer on the remaining input after a tab or space.  Returning the
   ;; result of that operation.  This effectively skips all whitespace.
   [(:or #\tab #\space) (return-without-pos (ratemática-lexer input-port))]
   ;; (token-newline) returns 'newline
   [#\newline (token-newline)]
   ;; Since (token-=) returns '=, just return the symbol directly
   [(:or "=" "+" "-" "*" "/" "!" "?") (string->symbol lexeme)]
   ["(" 'OP]
   [")" 'CP]
   ;; Variables start with a letter and can contain numbers and _
   [(:: (:or lower-letter upper-letter)
        (:* (:or lower-letter upper-letter digit "_"))) (token-VAR (string->symbol lexeme))]
   [(:+ digit) (token-NUM (string->number lexeme))]
   [(:: (:+ digit) #\. (:* digit)) (token-NUM (string->number lexeme))]
   [(:: "\"" (complement (:: any-string "\"" any-string)) "\"")
    (token-STR (substring lexeme 1 (sub1 (string-length lexeme))))]))

parser.rkt

#lang racket

;; A parser for Ratemática


;; Import the parser generators and lexer.
(require parser-tools/yacc
         parser-tools/lex
         syntax/readerr
         "lexer.rkt")

(provide (rename-out [r-read-syntax read-syntax]
                     [r-read read]))

(define (ratemática-parser source-name)
  (parser
   (src-pos)
   
   (start start)
   (end newline EOF)
   (tokens value-tokens op-tokens)
   (error (lambda (a name val start end)
           ;; (printf "~a, ~a, ~a, ~a~n" name val start end)
            (raise-read-error 
             "read-error"
             source-name
             (position-line start)
             (position-col start)
             (position-offset start)
             (- (position-offset end)
                (position-offset start)))))
   
   (precs (left - +)
          (left * /)
          (left NEG))
   
   (grammar
    
    (start [() eof]
           [(stmt) $1])
    
    (stmt [(STR) (build-so (list 'bang $1) 1 1)]
          [(exp !) (build-so (list 'bang $1) 1 2)]
          [(VAR = exp) (build-so (list 'equals $1 $3) 1 3)]
          [(exp) $1])
    
    (exp [(NUM) (build-so $1 1 1)]
         [(VAR) (build-so (list 'value-of $1) 1 1)]
         [(?) (build-so (list 'question) 1 1)]
         [(exp + exp) (build-so (list 'plus $1 $3) 1 3)]
         [(exp - exp) (build-so (list 'minus $1 $3) 1 3)]
         [(exp * exp) (build-so (list 'times $1 $3) 1 3)]
         [(exp / exp) (build-so (list 'divided-by $1 $3) 1 3)]
         [(- exp) (prec NEG) (build-so (list 'minus $2) 1 2)]
         [(OP exp CP) $2]))))


(define stx-for-original-property (read-syntax #f (open-input-string "original")))

;; A macro to build the syntax object
(define-syntax (build-so stx)
  (syntax-case stx ()
    ((_ value start end)
     (with-syntax ((start-pos (datum->syntax
                               (syntax end)
                               (string->symbol 
                                (format "$~a-start-pos"
                                        (syntax->datum (syntax start))))))
                   (end-pos (datum->syntax
                             (syntax end)
                             (string->symbol 
                              (format "$~a-end-pos"
                                      (syntax->datum (syntax end))))))
                   (source (datum->syntax
                            (syntax end)
                            'source-name)))
       (syntax
        (begin
     ;;     (printf "~a~n" value)
          (datum->syntax
           #f
           value
           (list source 
                 (position-line start-pos)
                 (position-col start-pos)
                 (position-offset start-pos)
                 (- (position-offset end-pos)
                    (position-offset start-pos)))
           stx-for-original-property)))))))

(define (rs sn ip)
  (port-count-lines! ip)
  ((ratemática-parser sn) (lambda () (ratemática-lexer ip))))

(define r-read-syntax
  (case-lambda ((sn) (rs sn (current-input-port)))
               ((sn ip) (rs sn ip))))

(define (r-read in)
  (match (r-read-syntax #f in)
    [(? syntax? s) (syntax->datum s)]
    [(? eof-object?) eof]))

semantics.rkt

#lang racket

(require rackunit)                ;; for unit testing
(provide (all-defined-out))

;; Creates a new environment to store variables
(define (new-env)
  (make-hash))

;; Assign a new variable
(define (assign env name value)
  (hash-set! env name value))

;; Retrieve value of a variable
(define (resolve env name)
  (hash-ref env name))

;; Write value to stdout
(define (write-to-stdout value)
  (display value))

;; Read value from stdin
(define (read-from-stdin)
  (read))

;; Arithmetic operations
(define-syntax-rule (plus a b)
  (+ a b))
(define-syntax-rule (minus a b)
  (- a b))
(define-syntax-rule (times a b)
  (* a b))
(define-syntax-rule (divided-by a b)
  (/ a b))

;; -----------------------------------------------------------

;; Assigment tests
(let ([e (new-env)])
  (assign e 'foo 42)
  (check-true (hash-has-key? e 'foo) "foo is assigned")
  (check-= 1 (hash-count e) 0 "Only one variable assigned")
  (check-= 42 (resolve e 'foo) 0 "foo is 42"))

;; Exercise standard input
(parameterize ([current-input-port (open-input-string "x = 142857")])
  (check-eq? 'x (read-from-stdin))
  (check-eq? '= (read-from-stdin))
  (check-eq? 142857 (read-from-stdin)))

;; Exercise stardard output
(let ([simulated-stdout (open-output-string)])
    (parameterize ([current-output-port simulated-stdout])
      (write-to-stdout "Ratemática\n")
      (write-to-stdout 142857))
    (check-equal? "Ratemática\n142857"
                  (get-output-string simulated-stdout)))

;; Test arithmetic operations
(check-= 42 (plus (plus 21 20) 1) 0)
(check-= 130 (plus 123.7 6.3) 0)
(check-= 42 (times 2 21) 0)
(check-= 91 (times 91/3 3) 0)
(check-= 0 (minus 8 8.0) 0)
(check-= 1 (divided-by 10 10) 0)
(check-= 4/3 (divided-by 8 6) 0)