fork download
copy 
  1. #! /usr/bin/env racket
  2. #lang racket
  3.  
  4. (require srfi/1 srfi/13 srfi/48 2htdp/batch-io)
  5.  
  6. ;SRFI 1: リストライブラリ
  7. ;https://w...content-available-to-author-only...s.com/ja/tech/srfi/srfi-1/srfi-1.html#drop
  8. ;SRFI 13: 文字列ライブラリ
  9. ;https://w...content-available-to-author-only...s.com/ja/tech/srfi/srfi-13/srfi-13.html
  10. ;SRFI 48: 中級の書式文字列
  11. ;https://w...content-available-to-author-only...s.com/ja/tech/srfi/srfi-48/srfi-48.html
  12. ;Batch Input/Output: "batch-io.rkt"
  13. ;https://d...content-available-to-author-only...g.org/teachpack/2htdpbatch-io.html#%28def._%28%28lib._2htdp%2Fbatch-io..rkt%29._read-file%29%29
  14.  
  15. ;;; Stack machine for running whitespace programs 
  16.  
  17. (define (vm prog stack cstack heap pc)
  18.   (let ((instr (list-ref prog pc)))
  19.     ((doInstr prog stack cstack heap (+ pc 1)) instr)))
  20.  
  21. ;; Running individual instructions
  22.  
  23. (define (doInstr prog stack cs heap pc)
  24.   (lambda (instr)
  25.     (case (car instr)
  26.       ((Push) (let ((n (cadr instr)))
  27.                 (vm prog (cons n stack) cs heap pc)))
  28.       ((Dup) (let ((n (car stack)))
  29.                (vm prog (cons n stack) cs heap pc)))
  30.       ((Ref) (let ((i (cadr instr)))
  31.                (vm prog
  32.                   (cons (list-ref stack i) stack)
  33.                   cs heap pc)))
  34.       ((Slide) (let ((i (cadr instr)) (n (car stack)))
  35.                  (vm prog
  36.                     (cons n (drop (cdr stack) i))
  37.                     cs heap pc)))
  38.       ((Swap) (let ((n (car stack)) (m (cadr stack)))
  39.                 (vm prog
  40.                    (cons m (cons n (cddr stack)))
  41.                    cs heap pc)))
  42.       ((Discard) (vm prog (cdr stack) cs heap pc))
  43.       ((Infix) (let ((op (cadr instr))
  44.                      (y (car stack))
  45.                      (x (cadr stack)))
  46.                  (vm prog
  47.                     (cons ((case op
  48.                              ((Plus) +)
  49.                              ((Minus) -)
  50.                              ((Times) *)
  51.                              ((Divide) /)
  52.                              ((Modulo) modulo))
  53.                            x y) (cddr stack))
  54.                     cs heap pc)))
  55.       ((OutputChar) (let ((n (car stack)))
  56.                       (write-char (integer->char n))
  57.                       (flush-output)
  58.                       (vm prog (cdr stack) cs heap pc)))
  59.       ((ReadChar) (let ((loc (car stack))
  60.                         (ch (read-char)))
  61.                     (let ((hp
  62.                            (store (char->integer ch) loc heap)))
  63.                       (vm prog (cdr stack) cs hp pc))))
  64.       ((ReadNum) (let ((loc (car stack))
  65.                        (ch (read-line)))
  66.                    (let ((num (string->number ch)))
  67.                      (let ((hp (store num loc heap)))
  68.                        (vm prog (cdr stack) cs hp pc)))))
  69.       ((OutputNum) (let ((n (car stack)))
  70.                      (write-string (number->string n))
  71.                      (flush-output)
  72.                      (vm prog (cdr stack) cs heap pc)))
  73.       ((Label) (let ((_ (cadr instr)))
  74.                  (vm prog stack cs heap pc)))
  75.       ((Call) (let ((l (cadr instr)))
  76.                 (let ((loc (findLabel l prog)))
  77.                   (vm prog stack (cons pc cs) heap loc))))
  78.       ((Jump) (let ((l (cadr instr)))
  79.                 (let ((loc (findLabel l prog)))
  80.                   (vm prog stack cs heap loc))))
  81.       ((If) (let ((t (cadr instr))
  82.                   (l (caddr instr))
  83.                   (n (car stack)))
  84.               (if ((case t
  85.                      ((Zero) zero?)
  86.                      ((Negative) negative?)) n)
  87.                  (let ((loc (findLabel l prog)))
  88.                    (vm prog (cdr stack) cs heap loc))
  89.                  (vm prog (cdr stack) cs heap pc))))
  90.       ((Return) (let ((c (car cs)))
  91.                   (vm prog stack (cdr cs) heap c)))
  92.       ((Store) (let ((n (car stack)) (loc (cadr stack)))
  93.                  (let ((hp (store n loc heap)))
  94.                    (vm prog (cddr stack) cs hp pc))))
  95.       ((Retrieve) (let ((loc (car stack)))
  96.                     (let ((val (retrieve loc heap)))
  97.                       (vm prog (cons val (cdr stack)) cs heap pc))))
  98.       ((End) (format #t "Done.~%Stack size ~a~%Heap size ~a~%"
  99.                     (length cs) (length heap)))
  100.       (else (error "Can't do " (car instr))))))
  101.  
  102. ;; Digging out labels from wherever they are
  103.  
  104. (define (findLabel l p)
  105.   (let loop ((p p) (i 0))
  106.     (if (null? p)
  107.        (error "Undefined label" l)
  108.        (let ((m (car p)))
  109.          (if (and (eq? (car m) 'Label) (eq? (cadr m) l))
  110.             i
  111.             (loop (cdr p) (+ i 1)))))))
  112.  
  113. ;; Heap management
  114.  
  115. (define (retrieve x heap) (list-ref heap x))
  116.  
  117. ;(define (store x n Heap)
  118. ;  (match (list x n Heap)
  119. ;    ((list x 0 (cons h hs)) (cons x hs))
  120. ;    ((list x n (cons h hs)) (let ((hp (store x (- n 1) hs)))
  121. ;                              (cons h hp)))
  122. ;    ((list x 0 '()) (cons x '()))
  123. ;    ((list x n '()) (let ((hp (store x (- n 1) '())))
  124. ;                      (cons 0 hp)))))
  125.  
  126. (define (store x n Heap)
  127.   (let ((h (length Heap)))
  128.     (if (< n h)
  129.        (let-values (((head tail) (split-at Heap n)))
  130.          (append head `(,x) (cdr tail)))
  131.        (append Heap (make-list (- n h) 0) `(,x)))))
  132.  
  133. ;input to the whitespace VM.
  134. ;For convinience, three input characters
  135. ;#\space, #\tab, #\newline
  136. ;
  137. ;Numbers are binary (#\space = 0, #\tab = 1, #\newline = terminator)
  138. ;Strings are sequences of binary characters, terminated by #\newline .
  139. ;
  140. ;We have:
  141. ;
  142. ;* Stack instructions (Preceded by #\space)
  143. ;      Push (Integer)     #\space
  144. ;      Dup      #\newline #\space
  145. ;      Swap    #\newline  #\tab
  146. ;      Discart #\newline #\newline
  147. ;
  148. ;* Arithmetic (Preceded by #\tab #\space)
  149. ;      Plus   #\space #\space
  150. ;      Minus  #\space #\tab
  151. ;      Times  #\space #\newline
  152. ;      Divide #\tab   #\space
  153. ;      Modulo #\tab   #\tab
  154. ;
  155. ;* Heap access (Preceded by #\tab #\tab)
  156. ;      Store     #\space
  157. ;      Retrieve #\tab
  158. ;
  159. ;* Control (Preceded by #\newline)
  160. ;      Label Symbol  #\space #\space
  161. ;      Call Label    #\space #\tab
  162. ;      Jump Label    #\space #\newline
  163. ;      If Zero Label #\tab #\space
  164. ;      If Neg Label  #\tab #\tab
  165. ;      Return         #\tab #\newline
  166. ;      End             #\newline #\newline
  167. ;
  168. ;* IO instructions (Preceded by #\tab #\newline)
  169. ;      OutputChar #\space #\space
  170. ;      OutputNum  #\space #\tab
  171. ;      ReadChar   #\tab #\space
  172. ;      ReadNum    #\tab #\tab
  173.  
  174. (define (execute fname)
  175.   (let ((prog (string-append (read-file fname) "\n")))
  176.     (let ((tokens (tokenize prog)))
  177.       (let ((runtime (parse tokens)))
  178.         (vm runtime '() '() '() 0)))))
  179.  
  180. (define (tokenize str)
  181.   (filter (lambda (x)
  182.             (or (char=? x #\space)
  183.                (char=? x #\tab)
  184.                (char=? x #\newline))) (string->list str)))
  185.  
  186. (define (parse ls)
  187.   (let loop ((ls ls) (acc '()))
  188.     (if (null? ls)
  189.        (reverse acc)
  190.        (match ls
  191.          ((list #\space #\space xs ...)
  192.           (let-values (((num rest) (parseNumber xs)))
  193.             (loop rest (cons `(Push ,num) acc))))
  194.          ((list #\space #\newline #\space xs ...)
  195.           (loop xs (cons '(Dup) acc)))
  196.          ((list #\space #\tab #\space xs ...)
  197.           (let-values (((num rest) (parseNumber xs)))
  198.             (loop rest (cons `(Ref ,num) acc))))
  199.          ((list #\space #\tab #\newline xs ...)
  200.           (let-values (((num rest) (parseNumber xs)))
  201.             (loop rest (cons `(Slide ,num) acc))))
  202.          ((list #\space #\newline #\tab xs ...)
  203.           (loop xs (cons '(Swap) acc)))
  204.          ((list #\space #\newline #\newline xs ...)
  205.           (loop xs (cons '(Discard) acc)))
  206.          ((list #\tab #\space #\space #\space xs ...)
  207.           (loop xs (cons '(Infix Plus) acc)))
  208.          ((list #\tab #\space #\space #\tab xs ...)
  209.           (loop xs (cons '(Infix Minus) acc)))
  210.          ((list #\tab #\space #\space #\newline xs ...)
  211.           (loop xs (cons '(Infix Times) acc)))
  212.          ((list #\tab #\space #\tab #\space xs ...)
  213.           (loop xs (cons '(Infix Divide) acc)))
  214.          ((list #\tab #\space #\tab #\tab xs ...)
  215.           (loop xs (cons '(infix Modulo) acc)))
  216.          ((list #\tab #\tab #\space xs ...)
  217.           (loop xs (cons '(Store) acc)))
  218.          ((list #\tab #\tab #\tab xs ...)
  219.           (loop xs (cons '(Retrieve) acc)))
  220.          ((list #\newline #\space #\space xs ...)
  221.           (let-values (((symbol rest) (parseSymbol xs)))
  222.             (loop rest (cons `(Label ,symbol) acc))))
  223.          ((list #\newline #\space #\tab xs ...)
  224.           (let-values (((symbol rest) (parseSymbol xs)))
  225.             (loop rest (cons `(Call ,symbol) acc))))
  226.          ((list #\newline #\space #\newline xs ...)
  227.           (let-values (((symbol rest) (parseSymbol xs)))
  228.             (loop rest (cons `(Jump ,symbol) acc))))
  229.          ((list #\newline #\tab #\space xs ...)
  230.           (let-values (((symbol rest) (parseSymbol xs)))
  231.             (loop rest (cons `(If Zero ,symbol) acc))))
  232.          ((list #\newline #\tab #\tab xs ...)
  233.           (let-values (((symbol rest) (parseSymbol xs)))
  234.             (loop rest (cons `(If Negative ,symbol) acc))))
  235.          ((list #\newline #\tab #\newline xs ...)
  236.           (loop xs (cons '(Return) acc)))
  237.          ((list #\newline #\newline #\newline xs ...)
  238.           (loop xs (cons '(End) acc)))
  239.          ((list #\tab #\newline #\space #\space xs ...)
  240.           (loop xs (cons '(OutputChar) acc)))
  241.          ((list #\tab #\newline #\space #\tab xs ...)
  242.           (loop xs (cons '(OutputNum) acc)))
  243.          ((list #\tab #\newline #\tab #\space xs ...)
  244.           (loop xs (cons '(ReadChar) acc)))
  245.          ((list #\tab #\newline #\tab #\tab xs ...)
  246.           (loop xs (cons '(ReadNum) acc)))
  247.          (else (error "Unrecognized input"))))))
  248.  
  249. (define (parseNumber ts)
  250.   (let loop ((ts ts) (acc '()))
  251.     (let ((x (car ts)) (rest (cdr ts)))
  252.       (if (char=? x #\newline)
  253.          (values (makeNumber acc) rest)
  254.          (loop rest (cons x acc))))))
  255.  
  256. (define (parseSymbol ts)
  257.   (let loop ((ts ts) (acc '()))
  258.     (let ((x (car ts)) (rest (cdr ts)))
  259.       (if (char=? x #\newline)
  260.          (values (makeSymbol acc) rest)
  261.          (loop rest (cons x acc))))))
  262.  
  263. (define (makeNumber t)
  264.   (let ((sign (last t)) (ls (reverse (take t (- (length t) 1)))))
  265.     (if (null? ls)
  266.        0
  267.        (let ((num (string->number
  268.                    (list->string
  269.                     (map (lambda (x)
  270.                            (cond ((char=? x #\space) #\0)
  271.                                 ((char=? x #\tab) #\1))) ls)) 2)))
  272.          (if (char=? sign #\space)
  273.             num
  274.             (- num))))))
  275.  
  276. (define (makeSymbol ls)
  277.   (let loop ((s (string-map (lambda (x)
  278.                               (cond ((char=? x #\space) #\0)
  279.                                    ((char=? x #\tab) #\1)))
  280.                            (list->string (reverse ls))))
  281.              (acc '()))
  282.     (if (string-null? s)
  283.        (string->symbol (list->string (reverse acc)))
  284.        (loop (string-drop s 8)
  285.             (cons (integer->char (string->number (string-take s 8) 2))
  286.                  acc)))))
  287.  
  288. (define (main args)
  289.   (if (not (= (length args) 1))
  290.      (usage)
  291.      (execute (car args))))
  292.  
  293. (define (usage)
  294.   (display "wspace with Racket 0.1 (c) 2021 Cametan\n")
  295.   (display "-------------------------------\n")
  296.   (display "Usage: wspace [file]\n"))
  297.  
  298. (main (vector->list (current-command-line-arguments)))
Success #stdin #stdout 1.09s 129264KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
Standard output is empty
https://ideone.com/s043hb
language:
Racket (racket 7.0)
created:
2 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!