common_lisp/core.lisp

   1 (require "types")
   2 (require "reader")
   3 (require "printer")
   4
   5 (defpackage :core
   6   (:use :common-lisp :types :reader :printer)
   7   (:export :ns))
   8
   9 (in-package :core)
  10
  11 (define-condition index-error (types:mal-error)
  12   ((size :initarg :size :reader size)
  13    (index :initarg :index :reader index)
  14    (sequence :initarg :sequence :reader sequence))
  15   (:report (lambda (condition stream)
  16              (format stream
  17                      "Index out of range (~a), length is ~a but index given was ~a"
  18                      (printer:pr-str (sequence condition))
  19                      (size condition)
  20                      (index condition)))))
  21
  22 (defun get-file-contents (filename)
  23   (with-open-file (stream filename)
  24     (let ((data (make-string (file-length stream))))
  25       (read-sequence data stream)
  26       data)))
  27
  28 (defvar ns
  29   (list
  30    (cons (types:make-mal-symbol '+)
  31          (types:make-mal-builtin-fn (lambda (value1 value2)
  32                                       (types:apply-unwrapped-values '+ value1 value2))))
  33
  34    (cons (types:make-mal-symbol '-)
  35          (types:make-mal-builtin-fn (lambda (value1 value2)
  36                                       (types:apply-unwrapped-values '- value1 value2))))
  37
  38    (cons (types:make-mal-symbol '*)
  39          (types:make-mal-builtin-fn (lambda (value1 value2)
  40                                       (types:apply-unwrapped-values '* value1 value2))))
  41
  42    (cons (types:make-mal-symbol '/)
  43          (types:make-mal-builtin-fn (   lambda (value1 value2)
  44                                       (types:apply-unwrapped-values '/ value1 value2))))
  45
  46    (cons (types:make-mal-symbol '|prn|)
  47          (types:make-mal-builtin-fn (lambda (&rest strings)
  48                                       (write-line (format nil
  49                                                           "~{~a~^ ~}"
  50                                                           (mapcar (lambda (string) (printer:pr-str string t))
  51                                                                   strings)))
  52                                       (types:make-mal-nil nil))))
  53
  54    (cons (types:make-mal-symbol '|println|)
  55          (types:make-mal-builtin-fn (lambda (&rest strings)
  56                                       (write-line (format nil
  57                                                           "~{~a~^ ~}"
  58                                                           (mapcar (lambda (string) (printer:pr-str string nil))
  59                                                                   strings)))
  60                                       (types:make-mal-nil nil))))
  61
  62    (cons (types:make-mal-symbol '|pr-str|)
  63          (types:make-mal-builtin-fn (lambda (&rest strings)
  64                                       (types:make-mal-string (format nil
  65                                                                      "~{~a~^ ~}"
  66                                                                      (mapcar (lambda (string) (printer:pr-str string t))
  67                                                                              strings))))))
  68
  69    (cons (types:make-mal-symbol '|str|)
  70          (types:make-mal-builtin-fn (lambda (&rest strings)
  71                                       (types:make-mal-string (format nil
  72                                                                      "~{~a~}"
  73                                                                      (mapcar (lambda (string) (printer:pr-str string nil))
  74                                                                              strings))))))
  75
  76    (cons (types:make-mal-symbol '|list|)
  77          (types:make-mal-builtin-fn (lambda (&rest values)
  78                                       (make-mal-list values))))
  79
  80    (cons (types:make-mal-symbol '|list?|)
  81          (types:make-mal-builtin-fn (lambda (value)
  82                                       (types:make-mal-boolean (or (types:mal-nil-p value)
  83                                                                   (types:mal-list-p value))))))
  84
  85    (cons (types:make-mal-symbol '|empty?|)
  86          (types:make-mal-builtin-fn (lambda (value)
  87                                       (types:make-mal-boolean (zerop (length (mal-value value)))))))
  88
  89    (cons (types:make-mal-symbol '|count|)
  90          (types:make-mal-builtin-fn (lambda (value)
  91                                       (types:apply-unwrapped-values 'length value))))
  92
  93    (cons (types:make-mal-symbol '=)
  94          (types:make-mal-builtin-fn (lambda (value1 value2)
  95                                       (types:make-mal-boolean (types:mal-value= value1 value2)))))
  96
  97    (cons (types:make-mal-symbol '<)
  98          (types:make-mal-builtin-fn (lambda (value1 value2)
  99                                       (types:apply-unwrapped-values-prefer-bool '<
 100                                                                                 value1
 101                                                                                 value2))))
 102
 103    (cons (types:make-mal-symbol '>)
 104          (types:make-mal-builtin-fn (lambda (value1 value2)
 105                                       (types:apply-unwrapped-values-prefer-bool '>
 106                                                                                 value1
 107                                                                                 value2))))
 108
 109    (cons (types:make-mal-symbol '<=)
 110          (types:make-mal-builtin-fn (lambda (value1 value2)
 111                                       (types:apply-unwrapped-values-prefer-bool '<=
 112                                                                                 value1
 113                                                                                 value2))))
 114
 115    (cons (types:make-mal-symbol '>=)
 116          (types:make-mal-builtin-fn (lambda (value1 value2)
 117                                       (types:apply-unwrapped-values-prefer-bool '>=
 118                                                                                 value1
 119                                                                                 value2))))
 120
 121    (cons (types:make-mal-symbol '|read-string|)
 122          (types:make-mal-builtin-fn (lambda (value)
 123                                       (reader:read-str (types:mal-value value)))))
 124
 125    (cons (types:make-mal-symbol '|slurp|)
 126          (types:make-mal-builtin-fn (lambda (filename)
 127                                       (types:apply-unwrapped-values 'get-file-contents filename))))
 128
 129    (cons (types:make-mal-symbol '|atom|)
 130          (types:make-mal-builtin-fn (lambda (value)
 131                                       (types:make-mal-atom value))))
 132
 133    (cons (types:make-mal-symbol '|atom?|)
 134          (types:make-mal-builtin-fn (lambda (value)
 135                                       (types:make-mal-boolean (types:mal-atom-p value)))))
 136
 137    (cons (types:make-mal-symbol '|deref|)
 138          (types:make-mal-builtin-fn (lambda (atom)
 139                                       (types:mal-value atom))))
 140
 141    (cons (types:make-mal-symbol '|reset!|)
 142          (types:make-mal-builtin-fn (lambda (atom value)
 143                                       (setf (types:mal-value atom) value))))
 144
 145    (cons (types:make-mal-symbol '|swap!|)
 146          (types:make-mal-builtin-fn (lambda (atom fn &rest args)
 147                                       (setf (types:mal-value atom)
 148                                             (apply (mal-value fn)
 149                                                    (append (list (types:mal-value atom))
 150                                                            args))))))
 151
 152    (cons (types:make-mal-symbol '|cons|)
 153          (types:make-mal-builtin-fn (lambda (element list)
 154                                       (types:make-mal-list (cons element
 155                                                                  (map 'list
 156                                                                       #'identity
 157                                                                       (mal-value list)))))))
 158
 159    (cons (types:make-mal-symbol '|concat|)
 160          (types:make-mal-builtin-fn (lambda (&rest lists)
 161                                       (types:make-mal-list (apply #'concatenate
 162                                                                   'list
 163                                                                   (mapcar #'types:mal-value lists))))))
 164
 165
 166    (cons (types:make-mal-symbol '|nth|)
 167          (types:make-mal-builtin-fn (lambda (sequence index)
 168                                       (or (nth (mal-value index)
 169                                                (map 'list #'identity (mal-value sequence)))
 170                                           (error 'index-error
 171                                                  :size (length (mal-value sequence))
 172                                                  :index (mal-value index)
 173                                                  :sequence sequence)))))
 174
 175    (cons (types:make-mal-symbol '|first|)
 176          (types:make-mal-builtin-fn (lambda (sequence)
 177                                       (or (first (map 'list #'identity (mal-value sequence)))
 178                                           (types:make-mal-nil nil)))))
 179
 180    (cons (types:make-mal-symbol '|rest|)
 181          (types:make-mal-builtin-fn (lambda (sequence)
 182                                       (types:make-mal-list (rest (map 'list
 183                                                                       #'identity
 184                                                                       (mal-value sequence)))))))))