★ /prog/ Challenge Vol. 5 ★

The challenge suggestion thread was too busy going nowhere, and I feel like writing some code, so here is a /prog/ challenge.

THE CHALLENGE:
Design a ^_toy programming language. You may implement either a compiler or interpreter, and you may write the implementation in any language of your choosing.

Post the source code to your implementation as well as programs in your language to accomplish ^{at least} two of the following tasks, plus one ``wild card'' program not listed here.

    • Factorial calculator
    • Fibonacci sequence generator
    • Prime number sieve (e.g. Eratosthenes, Atkin, etc.)
    • fgrep (output lines of input containing a given string)
    • Caesar cipher
    • Simple interactive calculator
    • Tic-tac-toe (AI not required)
    • The game of Nim (http://en.wikipedia.org/wiki/Nim)

Entries must be submitted prior to 2010-06-21 00:00, which gives one full week and two weekends. Judgment will be in three categories: presentation and cleverness of designed language, clarity of implementation, and overall usefulness/entertainment/trolling value of the ``wild card'' program.

Winner will receive ten Susscoins, to be transferred via /prog/mail.

It's not complete and I'm still working on the syntax.

(require parser-tools/yacc
         parser-tools/lex
         (prefix-in : parser-tools/lex-sre))


(define-empty-tokens infix-operators (cons append + * - ^ / // > < >= <= = :=))

(define-empty-tokens separators (comma open-paren close-paren
                                       open-bracket close-bracket
                                       open-brace close-brace
                                       => assign eof))

(define-empty-tokens keywords (ellipsis eq? eqv? equal? quote lambda let let* letrec in nil if then else cond))

(define-tokens values (lisp number identifier string))

(define-lex-abbrevs
  (%digit (:/ #\0 #\9))
  (%idchr (:or alphabetic "?" "!" "_"))
  (%string (:: #\" (complement (:: any-string #\" any-string)) #\"))
  (%number (:or (:+ %digit)
                (:: (:+ %digit) #\. (:+ %digit))))
  (%identifier (:: %idchr (:* (:or %digit %idchr)))))

(define lexit
  (lexer
   ((eof) 'eof)
   ((:: "--" (complement (:: any-string #\newline any-string)) #\newline) (lexit input-port))
   ((:: "{-" (complement (:: any-string "-}" any-string)) "-}") (lexit input-port))
   ((:or #\tab #\space #\newline) (lexit input-port))
   ((:or "=" ">=" "<=" ">" "<" "^" ":="
         "+" "*" "-" "/" "//") (string->symbol lexeme))
   ((:or "let" "let*" "letrec" "in" "if" "cond" "=>" "eq?" "eqv?" "equal?"
         "then" "else" "nil") (string->symbol lexeme))
   ((:or "λ" "lambda") (token-lambda))
   ((:or "'" "quote") (token-quote))
   ("..." (token-ellipsis))
   (":" (token-cons))
   ("++" (token-append))
   ("," (token-comma))
   ("{" (token-open-brace))
   ("}" (token-close-brace))
   ("[" (token-open-bracket))
   ("]" (token-close-bracket))
   ((:: "#(" any-string ")#") (token-lisp (substring lexeme 2 (- (string-length lexeme) 2))))
   ("(" (token-open-paren))
   (")" (token-close-paren))
   (%number (token-number (string->number lexeme)))
   (%string (token-string lexeme))
   (%identifier (token-identifier (string->symbol (regexp-replace* #rx"_" lexeme "-"))))))

(define parseit
  (parser
   (start top)
   (end eof)
   (tokens infix-operators separators keywords values)
   (error (λ x (displayln x)))
  
   (precs (right quote)
          (left + *)
          (left - / //)
          (right ^)
          (right cons append)
          (nonassoc >= > < <=)
          (right =)
          (right :=)
          (right comma))
  
   (grammar
    (top (() #f)
         ((stmt) $1)
         ((stmts) `(begin ,@$1))
         )
   
    (stmts
     ((stmt) `(,$1))
     ((stmt stmts) `(,$1 ,@$2)))
   
    (value
     ((number) $1)
     ((string) $1)
     ((fun) $1)
     ((nil) ''())
     ((list) `(quote ,$1))
     ((quote expr) `(quote ,$2)))
   
    (values
     ((value) `(,$1))
     ((value comma values) `(,$1 ,@$3)))
   
    (list
     ((open-bracket close-bracket) ''())
     ((open-bracket values close-bracket) `(,@$2)))
   
    (stmt
     ((expr) $1)
     ((identifier := expr) `(define ,$1 ,$3))
     ((identifier = expr) `(set! ,$1 ,$3)))
   
    (expr
     ((value) $1)
     ((fun) $1)
     ((lisp) $1)
     ((let bindings in expr) `(let ,$2 ,$4))
     ((let* bindings in expr) `(let* ,$2 ,$4))
     ((letrec bindings in expr) `(letrec ,$2 ,$4))
     ((cond condcases) `(cond ,@$2))
     ((if expr then expr) `(if ,$2 ,$4 #f))
     ((if expr then expr else expr) `(if ,$2 ,$4 ,$6))
     ((open-paren expr close-paren list-of-exprs) `(,$2 ,@$4))
     ((fun list-of-exprs) `(,$1 ,@$2))
     ((- expr) `(- ,$2))
     ((expr + expr) `(+ ,$1 ,$3))
     ((expr * expr) `(* ,$1 ,$3))
     ((expr / expr) `(/ ,$1 ,$3))
     ((expr // expr) `(quotient ,$1 ,$3))
     ((expr ^ expr) `(expt ,$1 ,$3))
     ((expr - expr) `(- ,$1 ,$3))
     ((expr > expr) `(> ,$1 ,$3))
     ((expr < expr) `(< ,$1 ,$3))
     ((expr >= expr) `(>= ,$1 ,$3))
     ((expr <= expr) `(<= ,$1 ,$3))
     ((expr = expr) `(= ,$1 ,$3))
     ((expr eq? expr) `(eq? ,$1 ,$3))
     ((expr eqv? expr) `(eqv? ,$1 ,$3))
     ((expr equal? expr) `(equal? ,$1 ,$3))
     ((expr cons expr) `(cons ,$1 ,$3))
     ((expr append expr) `(append ,$1 ,$3))
     ((open-paren expr close-paren) $2)
     ((open-brace exprs close-brace) `(begin ,@$2))
     ((lambdaexpr) $1)
     )
   
    (exprs
     ((expr) `(,$1))
     ((expr exprs) `(,$1 ,@$2)))
   
    (lambdaexpr ((lambda list-of-identifiers expr) `(lambda ,$2 ,$3)))
   
    (list-of-exprs
     ((open-paren close-paren) '())
     ((open-paren cexprs close-paren) $2))
   
    (cexprs
     ((expr) `(,$1))
     ((expr comma cexprs) `(,$1 ,@$3)))
   
    (identifiers
     (() '())
     ((identifier) `(,$1))
     ((identifier ellipsis) $1)
     ((identifier comma identifiers) `(,$1 ,@$3)))
   
    (list-of-identifiers
     ((open-paren identifiers close-paren) $2))
   
    (fun
     ((identifier) $1)
     ((open-paren + close-paren) '+)
     ((open-paren * close-paren) '*)
     ((open-paren / close-paren) '/)
     ((open-paren // close-paren) 'quotient)
     ((open-paren - close-paren) '-)
     ((open-paren > close-paren) '>)
     ((open-paren < close-paren) '<)
     ((open-paren = close-paren) '=)
     ((open-paren >= close-paren) '>=)
     ((open-paren <= close-paren) '<=)
     ((open-paren eq? close-paren) 'eq?)
     ((open-paren eqv? close-paren) 'eqv?)
     ((open-paren equal? close-paren) 'equal?)
     ((open-paren ^ close-paren) 'expt)
     ((open-paren cons close-paren) 'cons)
     ((open-paren append close-paren) 'append))
   
    (condcases
     ((condcase) `(,$1))
     ((condcase condcases) `(,$1 ,@$2)))
   
    (condcase
     ((open-bracket expr close-bracket) `(,$2))
     ((open-bracket expr expr close-bracket) `(,$2 ,$3))
     ((open-bracket expr => fun close-bracket) `(,$2 => ,$4))
     ((open-bracket else expr close-bracket) `(else ,$3)))
   
    (bindings
     ((binding) `(,$1))
     ((binding comma bindings) `(,$1 ,@$3)))
   
    (binding
     ((identifier = expr) `(,$1 ,$3))))))

(define (parse-port ip)
  (port-count-lines! ip)
  (letrec ((one-line
            (lambda ()
              (let ((result (parseit (lambda () (lexit ip)))))
                (if result result (one-line))))))
    (one-line)))
(define (parse-string s)
  (parse-port (open-input-string s)))

(parse-string "
fact := λ(x) letrec loop = λ(x,n) if zero?(x) then n else loop(x-1,x*n) in loop(x,1)
fibs := λ(x) letrec loop = λ(a,b,x,r) if zero?(x) then reverse(a:r) else loop(b,a+b,x-1,a:r) in loop(0,1,x,nil)
")
;'(begin
;   (define fact (lambda (x) (letrec ((loop (lambda (x n) (if (zero? x) n (loop (- x 1) (* x n)))))) (loop x 1))))
;   (define fibs (lambda (x) (letrec ((loop (lambda (a b x r) (if (zero? x) (reverse (cons a r)) (loop b (+ a b) (- x 1) (cons a r)))))) (loop 0 1 x '())))))