common-lisp/src/step2_eval.lisp

   1 (defpackage :mal
   2   (:use :common-lisp
   3         :types
   4         :env
   5         :reader
   6         :printer)
   7   (:import-from :cl-readline
   8                 :readline
   9                 :register-function)
  10   (:import-from :genhash
  11                 :hashref
  12                 :hashmap)
  13   (:import-from :utils
  14                 :getenv
  15                 :common-prefix)
  16   (:export :main))
  17
  18 (in-package :mal)
  19
  20 (defvar *repl-env* (make-mal-value-hash-table))
  21
  22 (setf (genhash:hashref (make-mal-symbol "+") *repl-env*)
  23       (make-mal-builtin-fn (lambda (value1 value2)
  24                                    (make-mal-number (+ (mal-data-value value1)
  25                                                        (mal-data-value value2))))))
  26
  27 (setf (genhash:hashref (make-mal-symbol "-") *repl-env*)
  28       (make-mal-builtin-fn (lambda (value1 value2)
  29                                    (make-mal-number (- (mal-data-value value1)
  30                                                        (mal-data-value value2))))))
  31
  32 (setf (genhash:hashref (make-mal-symbol "*") *repl-env*)
  33       (make-mal-builtin-fn (lambda (value1 value2)
  34                                    (make-mal-number (* (mal-data-value value1)
  35                                                        (mal-data-value value2))))))
  36
  37 (setf (genhash:hashref (make-mal-symbol "/") *repl-env*)
  38       (make-mal-builtin-fn (lambda (value1 value2)
  39                                    (make-mal-number (/ (mal-data-value value1)
  40                                                        (mal-data-value value2))))))
  41
  42 (defun lookup-env (symbol env)
  43   (let ((value (genhash:hashref symbol env)))
  44     (if value
  45         value
  46         (error 'env:undefined-symbol
  47                :symbol (format nil "~a" (mal-data-value symbol))))))
  48
  49 (defun eval-sequence (sequence env)
  50   (map 'list
  51        (lambda (ast) (mal-eval ast env))
  52        (mal-data-value sequence)))
  53
  54 (defun eval-hash-map (hash-map env)
  55   (let ((hash-map-value (mal-data-value hash-map))
  56         (new-hash-table (make-mal-value-hash-table)))
  57     (genhash:hashmap (lambda (key value)
  58                        (setf (genhash:hashref (mal-eval key env) new-hash-table)
  59                              (mal-eval value env)))
  60                      hash-map-value)
  61     (make-mal-hash-map new-hash-table)))
  62
  63 (defun eval-ast (ast env)
  64   (switch-mal-type ast
  65     (types:symbol (lookup-env ast env))
  66     (types:list (eval-sequence ast env))
  67     (types:vector (make-mal-vector (apply 'vector (eval-sequence ast env))))
  68     (types:hash-map (eval-hash-map ast env ))
  69     (types:any ast)))
  70
  71 (defun mal-read (string)
  72   (reader:read-str string))
  73
  74 (defun mal-eval (ast env)
  75   (cond
  76     ((not (mal-list-p ast)) (eval-ast ast env))
  77     ((zerop (length (mal-data-value ast))) ast)
  78     (t (progn
  79          (let ((evaluated-list (eval-ast ast env)))
  80            (apply (mal-data-value (car evaluated-list))
  81                   (cdr evaluated-list)))))))
  82
  83 (defun mal-print (expression)
  84   (printer:pr-str expression))
  85
  86 (defun rep (string)
  87   (handler-case
  88       (mal-print (mal-eval (mal-read string) *repl-env*))
  89     (error (condition)
  90       (format nil "~a" condition))))
  91
  92 (defvar *use-readline-p* nil)
  93
  94 (defun complete-toplevel-symbols (input &rest ignored)
  95   (declare (ignorable ignored))
  96
  97   (let (candidates)
  98     (loop for key being the hash-keys of *repl-env*
  99        when (let ((pos (search input key))) (and pos (zerop pos)))
 100        do (push key candidates))
 101
 102     (if (= 1 (length candidates))
 103         (cons (car candidates) candidates)
 104         (cons (apply #'utils:common-prefix candidates) candidates))))
 105
 106 (defun raw-input (prompt)
 107   (format *standard-output* prompt)
 108   (force-output *standard-output*)
 109   (read-line *standard-input* nil))
 110
 111 (defun mal-readline (prompt)
 112   (if *use-readline-p*
 113       (rl:readline :prompt prompt :add-history t :novelty-check #'string/=)
 114       (raw-input prompt)))
 115
 116 (defun mal-writeline (string)
 117   (when string
 118     (write-line string)
 119     (force-output *standard-output*)))
 120
 121 (defun main (&optional (argv nil argv-provided-p))
 122   (declare (ignorable argv argv-provided-p))
 123
 124   (setf *use-readline-p* (not (or (string= (utils:getenv "PERL_RL") "false")
 125                                   (string= (utils:getenv "TERM") "dumb"))))
 126
 127   ;; In GNU CLISP's batch mode the standard-input seems to be set to some sort
 128   ;; of input string-stream, this interacts wierdly with the PERL_RL enviroment
 129   ;; variable which the test runner sets causing `read-line' on *standard-input*
 130   ;; to fail with an empty stream error. The following reinitializes the
 131   ;; standard streams
 132   ;;
 133   ;; See http://www.gnu.org/software/clisp/impnotes/streams-interactive.html
 134   #+clisp (setf *standard-input* (ext:make-stream :input)
 135                 *standard-output* (ext:make-stream :output :buffered t)
 136                 *error-output* (ext:make-stream :error :buffered t))
 137
 138   ;; CCL fails with a error while registering completion function
 139   ;; See also https://github.com/mrkkrp/cl-readline/issues/5
 140   #-ccl (rl:register-function :complete #'complete-toplevel-symbols)
 141
 142   (loop do (let ((line (mal-readline "user> ")))
 143              (if line (mal-writeline (rep line)) (return)))))
 144
 145 ;;; Workaround for CMUCL's printing of "Reloaded library ... " messages when an
 146 ;;; image containing foreign libraries is restored. The extra messages cause the
 147 ;;; MAL testcases to fail
 148
 149 #+cmucl (progn
 150           (defvar *old-standard-output* *standard-output*
 151             "Keep track of current value standard output, this is restored after image restore completes")
 152
 153           (defun muffle-output ()
 154             (setf *standard-output* (make-broadcast-stream)))
 155
 156           (defun restore-output ()
 157             (setf *standard-output* *old-standard-output*))
 158
 159           (pushnew #'muffle-output ext:*after-save-initializations*)
 160           (setf ext:*after-save-initializations*
 161                 (append ext:*after-save-initializations* (list #'restore-output))))