Advertisement
Guest User

Untitled

a guest
Dec 18th, 2017
103
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. #!/usr/local/bin/txr
  2. (defvar *regs* #H(nil))
  3. (defvar *cpid* nil)
  4. (defvar *nsent* 0)
  5. (defvar *pc* 0)
  6. (defvar *tx* nil)
  7. (defvar *rx* nil)
  8. (defvar *prg*
  9.   (awk
  10.    (:let (prg nil))
  11.    (t (push (cons
  12.              (cond
  13.                ((equal (car f) "set") 'prg-set)
  14.                ((equal (car f) "mod") 'prg-mod)
  15.                (t (intern (car f))))
  16.              (mapcar (lambda (s)
  17.                        (cond
  18.                          ((not (chr-isalpha [s 0]))
  19.                           (int-str s))
  20.                          (t (list 'quote (intern s)))))
  21.                      (cdr f)))
  22.             prg))
  23.    (:end
  24.     (vec-list (nreverse prg)))))
  25.  
  26. (defun cleanup ()
  27.   (close-stream *tx*)
  28.   (close-stream *rx*)
  29.   (when *cpid*
  30.     (format t "~a\n" *nsent*)
  31.     (wait *cpid*))
  32.   (exit 0))
  33.  
  34. (defun retr (v)
  35.   (if (symbolp v) (or [*regs* v] 0) v))
  36.  
  37. (defun snd (x)
  38.   (catch (format *tx* "~a\n" (retr x))
  39.     (recover (e) (cleanup)))
  40.   (flush-stream *tx*)
  41.   (inc *nsent*)
  42.   (inc *pc*))
  43. (defun prg-set (x y)
  44.   (set [*regs* x] (retr y))
  45.   (inc *pc*))
  46. (defun add (x y)
  47.   (inc [*regs* x] (retr y))
  48.   (inc *pc*))
  49. (defun mul (x y)
  50.   (set [*regs* x] (* (or [*regs* x] 0) (retr y)))
  51.   (inc *pc*))
  52. (defun prg-mod (x y)
  53.   (set [*regs* x] (mod [*regs* x] (retr y)))
  54.   (inc *pc*))
  55. (defun rcv (x)
  56.   (if (poll (list (cons *rx* poll-in)) 5000)
  57.       (set [*regs* x] (int-str (or (get-line *rx*) (cleanup))))
  58.       ;the or is in case the get-line returns nil, indicating end of stream
  59.       (cleanup))
  60.   (inc *pc*))
  61. (defun jgz (x y)
  62.   (if (> (retr x) 0)
  63.       (inc *pc* (retr y))
  64.       (inc *pc*)))
  65.  
  66. (let* ((cwrite (pipe))
  67.        (pwrite (pipe))
  68.        (pid (fork)))
  69.   (unless (zerop pid)
  70.     (set *cpid* pid))
  71.   (let ((rp (if *cpid* cwrite pwrite))
  72.         (wp (if *ischld* pwrite cwrite)))
  73.     (set *tx* (open-fileno (cdr wp) "w"))
  74.     (close-stream (open-fileno (car wp) "r"))
  75.     (set *rx* (open-fileno (car rp) "r"))
  76.     (close-stream (open-fileno (cdr rp) "w"))
  77.     (set [*regs* 'p] (if *ischld* 0 1))))
  78.  
  79. (while (and (>= *pc* 0)
  80.             (< *pc* (len *prg*)))
  81.   (eval [*prg* *pc*]))
  82.  
  83. (cleanup)
Advertisement
Advertisement
Advertisement
RAW Paste Data Copied
Advertisement