- {env: IMPL=coffee, services: [docker]}
- {env: IMPL=cs, services: [docker]}
- {env: IMPL=chuck, services: [docker]}
- - {env: IMPL=clisp, services: [docker]}
- {env: IMPL=clojure, services: [docker]}
- {env: IMPL=common-lisp, services: [docker]}
- {env: IMPL=crystal, services: [docker]}
# Settings
#
-IMPLS = ada awk bash basic c d chuck clojure coffee clisp common-lisp cpp crystal cs dart \
+IMPLS = ada awk bash basic c d chuck clojure coffee common-lisp cpp crystal cs dart \
erlang elisp elixir es6 factor forth fsharp go groovy guile haskell \
haxe io java julia js kotlin logo lua make mal ocaml matlab miniMAL \
nim objc objpascal perl perl6 php pil plpgsql plsql powershell ps \
chuck_STEP_TO_PROG = chuck/$($(1)).ck
clojure_STEP_TO_PROG = clojure/target/$($(1)).jar
coffee_STEP_TO_PROG = coffee/$($(1)).coffee
-clisp_STEP_TO_PROG = clisp/$($(1)).fas
common-lisp_STEP_TO_PROG = common-lisp/$($(1))
cpp_STEP_TO_PROG = cpp/$($(1))
crystal_STEP_TO_PROG = crystal/$($(1))
+++ /dev/null
-((lisp-mode
- (inferior-lisp-program . "clisp")))
\ No newline at end of file
+++ /dev/null
-FROM ubuntu:vivid
-MAINTAINER Joel Martin <github@martintribe.org>
-
-##########################################################
-# General requirements for testing or common across many
-# implementations
-##########################################################
-
-RUN apt-get -y update
-
-# Required for running tests
-RUN apt-get -y install make python
-
-# Some typical implementation and test requirements
-RUN apt-get -y install curl libreadline-dev libedit-dev
-
-RUN mkdir -p /mal
-WORKDIR /mal
-
-##########################################################
-# Specific implementation requirements
-##########################################################
-
-# Install clisp
-RUN apt-get -y install clisp
+++ /dev/null
-SOURCES_BASE = utils.lisp types.lisp reader.lisp printer.lisp
-SOURCES_LISP = env.lisp core.lisp stepA_mal.lisp
-SOURCES = $(SOURCES_BASE) $(SOURCES_LISP)
-
-all : stepA_mal.fas
-
-.PHONY: stats
-
-step%.fas : step%.lisp dependencies.lisp utils.lisp types.lisp env.lisp printer.lisp reader.lisp core.lisp
- clisp -q -c $<
-
-clean:
- rm *.fas *.lib
-
-stats: $(SOURCES)
- @wc $^
- @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*;|^[[:space:]]*$$" $^ | wc` "[comments/blanks]"
-
-stats-lisp: $(SOURCES_LISP)
- @wc $^
- @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*;|^[[:space:]]*$$" $^ | wc` "[comments/blanks]"
+++ /dev/null
-Implementation of MAL in Common Lisp
-
-- This implementation is not portable and works only with CLISP
+++ /dev/null
-(defpackage :core
- (:use :common-lisp :types :reader :printer)
- (:export :ns))
-
-(in-package :core)
-
-(define-condition index-error (types:mal-runtime-exception)
- ((size :initarg :size :reader size)
- (index :initarg :index :reader index)
- (sequence :initarg :sequence :reader sequence))
- (:report (lambda (condition stream)
- (format stream
- "Index out of range (~a), length is ~a but index given was ~a"
- (printer:pr-str (sequence condition))
- (size condition)
- (index condition)))))
-
-(defun get-file-contents (filename)
- (with-open-file (stream filename)
- (let ((data (make-string (file-length stream))))
- (read-sequence data stream)
- data)))
-
-(defmacro wrap-boolean (form)
- `(if ,form
- types:mal-true
- types:mal-false))
-
-(defvar ns
- (list
- (cons (types:make-mal-symbol "+")
- (types:make-mal-builtin-fn (lambda (value1 value2)
- (types:apply-unwrapped-values '+ value1 value2))))
-
- (cons (types:make-mal-symbol "-")
- (types:make-mal-builtin-fn (lambda (value1 value2)
- (types:apply-unwrapped-values '- value1 value2))))
-
- (cons (types:make-mal-symbol "*")
- (types:make-mal-builtin-fn (lambda (value1 value2)
- (types:apply-unwrapped-values '* value1 value2))))
-
- (cons (types:make-mal-symbol "/")
- (types:make-mal-builtin-fn (lambda (value1 value2)
- (types:make-mal-number (floor (/ (types:mal-data-value value1)
- (types:mal-data-value value2)))))))
-
- (cons (types:make-mal-symbol "prn")
- (types:make-mal-builtin-fn (lambda (&rest strings)
- (write-line (format nil
- "~{~a~^ ~}"
- (mapcar (lambda (string) (printer:pr-str string t))
- strings)))
- types:mal-nil)))
-
- (cons (types:make-mal-symbol "println")
- (types:make-mal-builtin-fn (lambda (&rest strings)
- (write-line (format nil
- "~{~a~^ ~}"
- (mapcar (lambda (string) (printer:pr-str string nil))
- strings)))
- types:mal-nil)))
-
- (cons (types:make-mal-symbol "pr-str")
- (types:make-mal-builtin-fn (lambda (&rest strings)
- (types:make-mal-string (format nil
- "~{~a~^ ~}"
- (mapcar (lambda (string) (printer:pr-str string t))
- strings))))))
-
- (cons (types:make-mal-symbol "str")
- (types:make-mal-builtin-fn (lambda (&rest strings)
- (types:make-mal-string (format nil
- "~{~a~}"
- (mapcar (lambda (string) (printer:pr-str string nil))
- strings))))))
-
- (cons (types:make-mal-symbol "list")
- (types:make-mal-builtin-fn (lambda (&rest values)
- (make-mal-list values))))
-
- (cons (types:make-mal-symbol "list?")
- (types:make-mal-builtin-fn (lambda (value)
- (wrap-boolean (or (types:mal-nil-p value)
- (types:mal-list-p value))))))
-
- (cons (types:make-mal-symbol "empty?")
- (types:make-mal-builtin-fn (lambda (value)
- (wrap-boolean (zerop (length (mal-data-value value)))))))
-
- (cons (types:make-mal-symbol "count")
- (types:make-mal-builtin-fn (lambda (value)
- (types:apply-unwrapped-values 'length value))))
-
- (cons (types:make-mal-symbol "=")
- (types:make-mal-builtin-fn (lambda (value1 value2)
- (wrap-boolean (types:mal-value= value1 value2)))))
-
- (cons (types:make-mal-symbol "<")
- (types:make-mal-builtin-fn (lambda (value1 value2)
- (types:apply-unwrapped-values-prefer-bool '<
- value1
- value2))))
-
- (cons (types:make-mal-symbol ">")
- (types:make-mal-builtin-fn (lambda (value1 value2)
- (types:apply-unwrapped-values-prefer-bool '>
- value1
- value2))))
-
- (cons (types:make-mal-symbol "<=")
- (types:make-mal-builtin-fn (lambda (value1 value2)
- (types:apply-unwrapped-values-prefer-bool '<=
- value1
- value2))))
-
- (cons (types:make-mal-symbol ">=")
- (types:make-mal-builtin-fn (lambda (value1 value2)
- (types:apply-unwrapped-values-prefer-bool '>=
- value1
- value2))))
-
- (cons (types:make-mal-symbol "read-string")
- (types:make-mal-builtin-fn (lambda (value)
- (reader:read-str (types:mal-data-value value)))))
-
- (cons (types:make-mal-symbol "slurp")
- (types:make-mal-builtin-fn (lambda (filename)
- (types:apply-unwrapped-values 'get-file-contents filename))))
-
- (cons (types:make-mal-symbol "atom")
- (types:make-mal-builtin-fn (lambda (value)
- (types:make-mal-atom value))))
-
- (cons (types:make-mal-symbol "atom?")
- (types:make-mal-builtin-fn (lambda (value)
- (wrap-boolean (types:mal-atom-p value)))))
-
- (cons (types:make-mal-symbol "deref")
- (types:make-mal-builtin-fn (lambda (atom)
- (types:mal-data-value atom))))
-
- (cons (types:make-mal-symbol "reset!")
- (types:make-mal-builtin-fn (lambda (atom value)
- (setf (types:mal-data-value atom) value))))
-
- (cons (types:make-mal-symbol "swap!")
- (types:make-mal-builtin-fn (lambda (atom fn &rest args)
- (setf (types:mal-data-value atom)
- (apply (mal-data-value fn)
- (append (list (types:mal-data-value atom))
- args))))))
-
- (cons (types:make-mal-symbol "cons")
- (types:make-mal-builtin-fn (lambda (element list)
- (types:make-mal-list (cons element
- (map 'list
- #'identity
- (mal-data-value list)))))))
-
- (cons (types:make-mal-symbol "concat")
- (types:make-mal-builtin-fn (lambda (&rest lists)
- (types:make-mal-list (apply #'concatenate
- 'list
- (mapcar #'types:mal-data-value lists))))))
-
-
- (cons (types:make-mal-symbol "nth")
- (types:make-mal-builtin-fn (lambda (sequence index)
- (or (nth (mal-data-value index)
- (map 'list #'identity (mal-data-value sequence)))
- (error 'index-error
- :size (length (mal-data-value sequence))
- :index (mal-data-value index)
- :sequence sequence)))))
-
- (cons (types:make-mal-symbol "first")
- (types:make-mal-builtin-fn (lambda (sequence)
- (or (first (map 'list #'identity (mal-data-value sequence)))
- types:mal-nil))))
-
- (cons (types:make-mal-symbol "rest")
- (types:make-mal-builtin-fn (lambda (sequence)
- (types:make-mal-list (rest (map 'list
- #'identity
- (mal-data-value sequence)))))))
-
- (cons (types:make-mal-symbol "throw")
- (types:make-mal-builtin-fn (lambda (value)
- (error 'types:mal-user-exception
- :data value))))
-
- (cons (types:make-mal-symbol "apply")
- (types:make-mal-builtin-fn (lambda (fn &rest values)
- (let ((final-arg (map 'list
- #'identity
- (types:mal-data-value (car (last values)))))
- (butlast-args (butlast values)))
- (apply (types:mal-data-value fn)
- (append butlast-args final-arg))))))
-
- (cons (types:make-mal-symbol "map")
- (types:make-mal-builtin-fn (lambda (fn sequence)
- (let ((applicants (map 'list
- #'identity
- (types:mal-data-value sequence))))
- (types:make-mal-list (mapcar (types:mal-data-value fn)
- applicants))))))
-
- (cons (types:make-mal-symbol "nil?")
- (types:make-mal-builtin-fn (lambda (value)
- (wrap-boolean (types:mal-nil-p value)))))
-
- (cons (types:make-mal-symbol "true?")
- (types:make-mal-builtin-fn (lambda (value)
- (wrap-boolean (and (types:mal-boolean-p value)
- (types:mal-data-value value))))))
-
- (cons (types:make-mal-symbol "false?")
- (types:make-mal-builtin-fn (lambda (value)
- (wrap-boolean (and (types:mal-boolean-p value)
- (not (types:mal-data-value value)))))))
-
- (cons (types:make-mal-symbol "symbol?")
- (types:make-mal-builtin-fn (lambda (value)
- (wrap-boolean (types:mal-symbol-p value)))))
-
- (cons (types:make-mal-symbol "symbol")
- (types:make-mal-builtin-fn (lambda (string)
- (types:make-mal-symbol (types:mal-data-value string)))))
-
- (cons (types:make-mal-symbol "keyword")
- (types:make-mal-builtin-fn (lambda (keyword)
- (if (types:mal-keyword-p keyword)
- keyword
- (types:make-mal-keyword (format nil ":~a" (types:mal-data-value keyword)))))))
-
- (cons (types:make-mal-symbol "keyword?")
- (types:make-mal-builtin-fn (lambda (value)
- (wrap-boolean (types:mal-keyword-p value)))))
-
- (cons (types:make-mal-symbol "vector")
- (types:make-mal-builtin-fn (lambda (&rest elements)
- (types:make-mal-vector (map 'vector #'identity elements)))))
-
- (cons (types:make-mal-symbol "vector?")
- (types:make-mal-builtin-fn (lambda (value)
- (wrap-boolean (types:mal-vector-p value)))))
-
- (cons (types:make-mal-symbol "hash-map")
- (types:make-mal-builtin-fn (lambda (&rest elements)
- (let ((hash-map (make-hash-table :test 'types:mal-value=)))
- (loop
- for (key value) on elements
- by #'cddr
- do (setf (gethash key hash-map) value))
- (types:make-mal-hash-map hash-map)))))
-
- (cons (types:make-mal-symbol "map?")
- (types:make-mal-builtin-fn (lambda (value)
- (wrap-boolean (types:mal-hash-map-p value)))))
-
- (cons (types:make-mal-symbol "assoc")
- (types:make-mal-builtin-fn (lambda (hash-map &rest elements)
- (let ((hash-map-value (types:mal-data-value hash-map))
- (new-hash-map (make-hash-table :test 'types:mal-value=)))
-
- (loop
- for key being the hash-keys of hash-map-value
- do (setf (gethash key new-hash-map)
- (gethash key hash-map-value)))
-
- (loop
- for (key value) on elements
- by #'cddr
- do (setf (gethash key new-hash-map) value))
-
- (types:make-mal-hash-map new-hash-map)))))
-
- (cons (types:make-mal-symbol "dissoc")
- (types:make-mal-builtin-fn (lambda (hash-map &rest elements)
- (let ((hash-map-value (types:mal-data-value hash-map))
- (new-hash-map (make-hash-table :test 'types:mal-value=)))
-
- (loop
- for key being the hash-keys of hash-map-value
- do (when (not (member key elements :test #'types:mal-value=))
- (setf (gethash key new-hash-map)
- (gethash key hash-map-value))))
-
- (types:make-mal-hash-map new-hash-map)))))
-
- (cons (types:make-mal-symbol "get")
- (types:make-mal-builtin-fn (lambda (hash-map key)
- (or (and (types:mal-hash-map-p hash-map)
- (gethash key (types:mal-data-value hash-map)))
- types:mal-nil))))
-
- (cons (types:make-mal-symbol "contains?")
- (types:make-mal-builtin-fn (lambda (hash-map key)
- (if (gethash key (types:mal-data-value hash-map))
- types:mal-true
- types:mal-false))))
-
- (cons (types:make-mal-symbol "keys")
- (types:make-mal-builtin-fn (lambda (hash-map)
- (let ((hash-map-value (types:mal-data-value hash-map)))
- (types:make-mal-list (loop
- for key being the hash-keys of hash-map-value
- collect key))))))
-
- (cons (types:make-mal-symbol "vals")
- (types:make-mal-builtin-fn (lambda (hash-map)
- (let ((hash-map-value (types:mal-data-value hash-map)))
- (types:make-mal-list (loop
- for key being the hash-keys of hash-map-value
- collect (gethash key hash-map-value)))))))
-
- (cons (types:make-mal-symbol "sequential?")
- (types:make-mal-builtin-fn (lambda (value)
- (wrap-boolean (or (types:mal-vector-p value)
- (types:mal-list-p value))))))
-
- (cons (types:make-mal-symbol "readline")
- (types:make-mal-builtin-fn (lambda (prompt)
- (format *standard-output* (types:mal-data-value prompt))
- (force-output *standard-output*)
- (types:wrap-value (read-line *standard-input* nil)))))
-
- (cons (types:make-mal-symbol "string?")
- (types:make-mal-builtin-fn (lambda (value)
- (wrap-boolean (types:mal-string-p value)))))
-
- (cons (types:make-mal-symbol "time-ms")
- (types:make-mal-builtin-fn (lambda ()
-
- (types:make-mal-number (floor (/ (get-internal-real-time)
- (/ internal-time-units-per-second
- 1000)))))))
-
- (cons (types:make-mal-symbol "conj")
- (types:make-mal-builtin-fn (lambda (value &rest elements)
- (cond ((types:mal-list-p value)
- (types:make-mal-list (append (nreverse elements)
- (types:mal-data-value value))))
- ((types:mal-vector-p value)
- (types:make-mal-vector (concatenate 'vector
- (types:mal-data-value value)
- elements)))
- (t (error 'types:mal-user-exception))))))
- (cons (types:make-mal-symbol "seq")
- (types:make-mal-builtin-fn (lambda (value)
- (if (zerop (length (types:mal-data-value value)))
- types:mal-nil
- (cond ((types:mal-list-p value)
- value)
- ((types:mal-vector-p value)
- (types:make-mal-list (map 'list
- #'identity
- (types:mal-data-value value))))
- ((types:mal-string-p value)
- (types:make-mal-list (map 'list
- (lambda (char)
- (types:make-mal-string (make-string 1 :initial-element char)))
- (types:mal-data-value value))))
- (t (error 'types:mal-user-exception)))))))
-
- (cons (types:make-mal-symbol "with-meta")
- (types:make-mal-builtin-fn (lambda (value meta)
- (funcall (switch-mal-type value
- (types:string #'types:make-mal-string)
- (types:symbol #'types:make-mal-symbol)
- (types:list #'types:make-mal-list)
- (types:vector #'types:make-mal-vector)
- (types:hash-map #'types:make-mal-hash-map)
- (types:fn #'types:make-mal-fn)
- (types:builtin-fn #'types:make-mal-builtin-fn))
- (types:mal-data-value value)
- :meta meta
- :attrs (types:mal-data-attrs value)))))
-
- (cons (types:make-mal-symbol "meta")
- (types:make-mal-builtin-fn (lambda (value)
- (or (types:mal-data-meta value)
- types:mal-nil))))
-
- ;; Since a nil in clisp may mean an empty list or boolean false or simply nil, the
- ;; caller can specify the preferred type while evaluating an expression
- (cons (types:make-mal-symbol "clisp-eval")
- (types:make-mal-builtin-fn (lambda (code &optional booleanp listp)
- (types:wrap-value (eval (read-from-string (types:mal-data-value code)))
- :booleanp (and booleanp (types:mal-data-value booleanp))
- :listp (and listp (types:mal-data-value listp))))))
-
- (cons (types:make-mal-symbol "define-builtin")
- (types:make-mal-builtin-fn (lambda (arglist &rest body)
- (let* ((func-args (types:unwrap-value arglist))
- (func-body (mapcar #'types:unwrap-value body))
- (func (eval `(lambda ,func-args ,@func-body))))
- (types:make-mal-builtin-fn (lambda (&rest args)
- (types:wrap-value (apply func
- (mapcar #'types:unwrap-value args)))))))))))
+++ /dev/null
-(require "utils")
-(require "types")
-(require "env")
-(require "reader")
-(require "printer")
-(require "core")
+++ /dev/null
-(defpackage :env
- (:use :common-lisp :types)
- (:export :undefined-symbol
- :mal-env
- :create-mal-env
- :get-env
- :find-env
- :set-env))
-
-(in-package :env)
-
-(define-condition undefined-symbol (types:mal-runtime-exception)
- ((symbol :initarg :symbol :reader symbol))
- (:report (lambda (condition stream)
- (format stream
- "'~a' not found"
- (symbol condition)))))
-
-(define-condition arity-mismatch (types:mal-runtime-exception)
- ((required :initarg :required :reader required)
- (provided :initarg :provided :reader provided))
- (:report (lambda (condition stream)
- (format stream
- "Unexpected number of arguments provided, expected ~a, got ~a"
- (required condition)
- (provided condition)))))
-
-(defstruct mal-env
- (bindings (make-hash-table :test 'equal) :read-only t)
- (parent nil :read-only t))
-
-(defun find-env (env symbol)
- (let ((value (gethash (types:mal-data-value symbol)
- (mal-env-bindings env)))
- (parent (mal-env-parent env)))
- (cond
- (value value)
- (parent (find-env parent symbol))
- (t nil))))
-
-(defun get-env (env symbol)
- (let ((value (find-env env symbol)))
- (if value
- value
- (error 'undefined-symbol
- :symbol (format nil "~a" (types:mal-data-value symbol))))))
-
-(defun set-env (env symbol value)
- (setf (gethash (types:mal-data-value symbol)
- (mal-env-bindings env))
- value))
-
-(defun create-mal-env (&key (parent nil) (binds nil) (exprs nil))
- (let ((varidiac-position (position (types:make-mal-symbol "&")
- binds
- :test #'mal-value=)))
- (when varidiac-position
- (setf (subseq binds varidiac-position (length binds))
- (list (nth (1+ varidiac-position) binds)))
- (setf binds (subseq binds 0 (1+ varidiac-position)))
-
- (let* ((no-of-args (length exprs))
- ;; There are enough arguments for variadic operator
- ;; to consume
- (rest-args (cond ((>= no-of-args (1+ varidiac-position))
- (make-mal-list (subseq exprs
- varidiac-position
- (length exprs))))
- ;; There are enough parameters to satisfy the
- ;; normal arguments, set rest-args to a nil value
- ((= no-of-args varidiac-position)
- types:mal-nil))))
- (handler-case
- (setf exprs (concatenate 'list
- (subseq exprs 0 varidiac-position)
- (list rest-args)))
- (simple-type-error (condition)
- (error 'arity-mismatch
- :required (length binds)
- :provided (length exprs))))))
-
- (when (not (= (length binds) (length exprs)))
- (error 'arity-mismatch
- :required (length binds)
- :provided (length exprs)))
-
- (let ((arg-params (map 'list #'cons binds exprs))
- (bindings (make-hash-table :test 'equal)))
- (dolist (arg-param arg-params)
- (setf (gethash (types:mal-data-value (car arg-param)) bindings)
- (cdr arg-param)))
- (make-mal-env :bindings bindings :parent parent))))
+++ /dev/null
-(defpackage :printer
- (:use :common-lisp :utils :types)
- (:export :pr-str))
-
-(in-package :printer)
-
-(defun pr-mal-sequence (start-delimiter sequence end-delimiter &optional (print-readably t))
- (concatenate 'string
- start-delimiter
- (format nil
- "~{~a~^ ~}"
- (map 'list (lambda (value)
- (pr-str value print-readably))
- (types:mal-data-value sequence)))
- end-delimiter))
-
-(defun pr-mal-hash-map (hash-map &optional (print-readably t))
- (let ((hash-map-value (types:mal-data-value hash-map)))
- (concatenate 'string
- "{"
- (format nil
- "~{~a~^ ~}"
- (let (entries)
- (maphash (lambda (key value)
- (push (format nil
- "~a ~a"
- (pr-str key print-readably)
- (pr-str value print-readably))
- entries))
- hash-map-value)
- (nreverse entries)))
- "}")))
-
-(defun pr-string (ast &optional (print-readably t))
- (if print-readably
- (utils:replace-all (prin1-to-string (types:mal-data-value ast))
- "
-"
- "\\n")
- (types:mal-data-value ast)))
-
-(defun pr-str (ast &optional (print-readably t))
- (when ast
- (switch-mal-type ast
- (types:number (format nil "~d" (types:mal-data-value ast)))
- (types:boolean (if (types:mal-data-value ast) "true" "false"))
- (types:nil "nil")
- (types:string (pr-string ast print-readably))
- (types:symbol (types:mal-data-value ast))
- (types:keyword (types:mal-data-value ast))
- (types:list (pr-mal-sequence "(" ast ")" print-readably))
- (types:vector (pr-mal-sequence "[" ast "]" print-readably))
- (types:hash-map (pr-mal-hash-map ast print-readably))
- (types:atom (format nil "(atom ~a)" (pr-str (types:mal-data-value ast))))
- (types:fn "#<function>")
- (types:builtin-fn "#<builtin function>"))))
+++ /dev/null
-(defpackage :reader
- (:use :common-lisp :regexp :utils :types)
- (:export :read-str
- :eof))
-
-(in-package :reader)
-
-(defvar *string-re* (regexp:regexp-compile "^\"\\(\\\\\\(.\\|
-\\)\\|[^\"\\]\\)*\"$")
- "Regular expression to match string")
-
-(defvar *digit-re* (regexp:regexp-compile "^\\(-\\|+\\)\\?[[:digit:]]\\+$")
- "Regular expression to match digits")
-
-(defvar *tokenizer-re* (regexp:regexp-compile "[[:space:],]*\\(~@\\|[][{}()~`'^@]\\|\"\\(\\\\\\(.\\|
-\\)\\|[^\"\\]\\)*\"\\?\\|;[^
-]*\\|[^][[:space:]~{}()@^`'\";]*\\)")
- "Regular expression to match LISP code")
-
-(define-condition eof (types:mal-error)
- ((context :initarg :context :reader context))
- (:report (lambda (condition stream)
- (format stream
- "EOF encountered while reading ~a"
- (context condition)))))
-
-(defun parse-string (token)
- (if (and (> (length token) 1)
- (regexp:regexp-exec *string-re* token))
- (progn
- (read-from-string (utils:replace-all token
- "\\n"
- "
-")))
- ;; A bit inaccurate
- (error 'eof
- :context "string")))
-
-;; Useful to debug regexps
-(defun test-re (re string)
- (let ((match (regexp:match re string)))
- (when match
- (regexp:match-string string match))))
-
-(defun test-tokenizer (re string)
- (let ((*tokenizer-re* re))
- (tokenize string)))
-
-(defun tokenize (string)
- (let (tokens)
- (do* ((start 0)
- (end (length string))
- (match t))
- ((not match))
- (setf match (when (< start end)
- (nth-value 1
- (regexp:regexp-exec *tokenizer-re* string :start start))))
- (when match
- (setf start (regexp:match-end match))
- (let ((token (string-trim "," (regexp:match-string string match))))
- (unless (or (zerop (length token))
- (char= (char token 0) #\;))
- (push token tokens)))))
- (nreverse tokens)))
-
-(defstruct (token-reader)
- (tokens nil))
-
-(defun peek (reader)
- (car (token-reader-tokens reader)))
-
-(defun next (reader)
- (pop (token-reader-tokens reader)))
-
-(defun consume (reader)
- (pop (token-reader-tokens reader))
- reader)
-
-(defun read-str (string)
- (read-form (make-token-reader :tokens (tokenize string))))
-
-(defun read-form (reader)
- (let ((token (peek reader)))
- (cond
- ((null token) nil)
- ((string= token "(") (make-mal-list (read-mal-sequence reader
- ")"
- 'list)))
- ((string= token "[") (make-mal-vector (read-mal-sequence reader
- "]"
- 'vector)))
- ((string= token "{") (make-mal-hash-map (read-hash-map reader)))
- ((string= token "^") (read-form-with-meta reader))
- ((member token '("'" "`" "~" "~@" "@") :test #'string= ) (expand-quote reader))
- (t (read-atom reader)))))
-
-(defun read-form-with-meta (reader)
- (consume reader)
- (let ((meta (read-form reader))
- (value (read-form reader)))
-
- (when (or (null meta)
- (null value))
- (error 'eof
- :context "object metadata"))
-
- (make-mal-list (list (make-mal-symbol "with-meta") value meta))))
-
-(defun expand-quote (reader)
- (let ((quote (next reader)))
- (make-mal-list (list (make-mal-symbol (cond
- ((string= quote "'") "quote")
- ((string= quote "`") "quasiquote")
- ((string= quote "~") "unquote")
- ((string= quote "~@") "splice-unquote")
- ((string= quote "@") "deref")))
- (read-form reader)))))
-
-(defun read-mal-sequence (reader &optional (delimiter ")") (constructor 'list))
- ;; Consume the opening brace
- (consume reader)
- (let (forms)
- (loop
- for token = (peek reader)
- while (cond
- ((null token) (error 'eof
- :context (if (string= delimiter ")")
- "list"
- "vector")))
- ((string= token delimiter) (return))
- (t (push (read-form reader) forms))))
- ;; Consume the closing brace
- (consume reader)
- (apply constructor (nreverse forms))))
-
-(defun read-hash-map (reader)
- ;; Consume the open brace
- (consume reader)
- (let (forms)
- (loop
- for token = (peek reader)
- while (cond
- ((null token) (error 'eof
- :context "hash-map"))
- ((string= token "}") (return))
- (t (let ((key (read-form reader))
- (value (read-form reader)))
- (if (null value)
- (error 'eof
- :context "hash-map")
- (push (cons key value) forms))))))
- ;; Consume the closing brace
- (consume reader)
- (make-hash-table :test 'types:mal-value=
- :initial-contents (nreverse forms))))
-
-(defun read-atom (reader)
- (let ((token (next reader)))
- (cond
- ((string= token "false")
- types:mal-false)
- ((string= token "true")
- types:mal-true)
- ((string= token "nil")
- types:mal-nil)
- ((char= (char token 0) #\")
- (make-mal-string (parse-string token)))
- ((char= (char token 0) #\:)
- (make-mal-keyword token))
- ((regexp:regexp-exec *digit-re* token)
- (make-mal-number (read-from-string token)))
- (t (make-mal-symbol token)))))
+++ /dev/null
-#!/bin/bash
-exec clisp $(dirname $0)/${STEP:-stepA_mal}.fas "${@}"
+++ /dev/null
-(defpackage :mal
- (:use :common-lisp
- :readline))
-
-(in-package :mal)
-
-(defun mal-read (string)
- string)
-
-(defun mal-eval (ast env)
- ast)
-
-(defun mal-print (expression)
- expression)
-
-(defun rep (string)
- (mal-print (mal-eval (mal-read string)
- (make-hash-table :test #'equal))))
-
-;; Readline setup
-;;; The test runner sets this environment variable, in which case we do
-;;; use readline since tests do not work with the readline interface
-(defvar use-readline-p (not (string= (ext:getenv "PERL_RL") "false")))
-
-(defvar *history-file* (namestring (merge-pathnames (user-homedir-pathname)
- ".mal-clisp-history")))
-
-(defun load-history ()
- (readline:read-history *history-file*))
-
-(defun save-history ()
- (readline:write-history *history-file*))
-
-;; Setup history
-(when use-readline-p
- (load-history))
-
-(defun raw-input (prompt)
- (format *standard-output* prompt)
- (force-output *standard-output*)
- (read-line *standard-input* nil))
-
-(defun mal-readline (prompt)
- (let ((input (if use-readline-p
- (readline:readline prompt)
- (raw-input prompt))))
- (when (and use-readline-p
- input
- (not (zerop (length input))))
- (readline:add-history input))
- input))
-
-(defun mal-writeline (string)
- (when string
- (write-line string)))
-
-(defun main ()
- (loop do (let ((line (mal-readline "user> ")))
- (if line
- (mal-writeline (rep line))
- (return))))
- (when use-readline-p
- (save-history)))
-
-;; Do not start REPL inside Emacs
-(unless (member :swank *features*)
- (main))
+++ /dev/null
-(require "dependencies")
-
-(defpackage :mal
- (:use :common-lisp
- :readline
- :reader
- :printer))
-
-(in-package :mal)
-
-(defun mal-read (string)
- (reader:read-str string))
-
-(defun mal-eval (ast env)
- ast)
-
-(defun mal-print (expression)
- (printer:pr-str expression))
-
-(defun rep (string)
- (handler-case
- (mal-print (mal-eval (mal-read string)
- nil))
- (reader:eof (condition)
- (format nil
- "~a"
- condition))))
-
-;; Readline setup
-;;; The test runner sets this environment variable, in which case we do
-;;; use readline since tests do not work with the readline interface
-(defvar use-readline-p (not (string= (ext:getenv "PERL_RL") "false")))
-
-(defvar *history-file* (namestring (merge-pathnames (user-homedir-pathname)
- ".mal-clisp-history")))
-
-(defun load-history ()
- (readline:read-history *history-file*))
-
-(defun save-history ()
- (readline:write-history *history-file*))
-
-;; Setup history
-(when use-readline-p
- (load-history))
-
-(defun raw-input (prompt)
- (format *standard-output* prompt)
- (force-output *standard-output*)
- (read-line *standard-input* nil))
-
-(defun mal-readline (prompt)
- (let ((input (if use-readline-p
- (readline:readline prompt)
- (raw-input prompt))))
- (when (and use-readline-p
- input
- (not (zerop (length input))))
- (readline:add-history input))
- input))
-
-(defun mal-writeline (string)
- (when string
- (write-line string)))
-
-(defun main ()
- (loop do (let ((line (mal-readline "user> ")))
- (if line
- (mal-writeline (rep line))
- (return))))
- (when use-readline-p
- (save-history)))
-
-;; Do not start REPL inside Emacs
-(unless (member :swank *features*)
- (main))
+++ /dev/null
-(require "dependencies")
-
-(defpackage :mal
- (:use :common-lisp
- :readline
- :types
- :env
- :reader
- :printer))
-
-(in-package :mal)
-
-;; Environment
-
-(defvar *repl-env* (make-hash-table :test 'types:mal-value=))
-
-(setf (gethash (types:make-mal-symbol "+") *repl-env*)
- (types:make-mal-builtin-fn (lambda (value1 value2)
- (apply-unwrapped-values '+
- value1
- value2))))
-
-(setf (gethash (types:make-mal-symbol "-") *repl-env*)
- (types:make-mal-builtin-fn (lambda (value1 value2)
- (apply-unwrapped-values '-
- value1
- value2))))
-
-(setf (gethash (types:make-mal-symbol "*") *repl-env*)
- (types:make-mal-builtin-fn (lambda (value1 value2)
- (apply-unwrapped-values '*
- value1
- value2))))
-
-(setf (gethash (types:make-mal-symbol "/") *repl-env*)
- (types:make-mal-builtin-fn (lambda (value1 value2)
- (apply-unwrapped-values '/
- value1
- value2))))
-
-(defun lookup-env (symbol env)
- (let ((value (gethash symbol env)))
- (if value
- value
- (error 'env:undefined-symbol
- :symbol (format nil "~a" (types:mal-data-value symbol))))))
-
-(defun mal-read (string)
- (reader:read-str string))
-
-(defun mal-eval (ast env)
- (cond
- ((not (types:mal-list-p ast)) (eval-ast ast env))
- ((zerop (length (mal-data-value ast))) ast)
- (t (progn
- (let ((evaluated-list (eval-ast ast env)))
- (apply (mal-data-value (car evaluated-list))
- (cdr evaluated-list)))))))
-
-(defun mal-print (expression)
- (printer:pr-str expression))
-
-(defun eval-sequence (sequence env)
- (map 'list
- (lambda (ast) (mal-eval ast env))
- (mal-data-value sequence)))
-
-(defun eval-hash-map (hash-map env)
- (let ((hash-map-value (mal-data-value hash-map))
- (new-hash-table (make-hash-table :test 'types:mal-value=)))
- (loop
- for key being the hash-keys of hash-map-value
- do (setf (gethash key new-hash-table)
- (mal-eval (gethash key hash-map-value) env)))
- (make-mal-hash-map new-hash-table)))
-
-(defun eval-ast (ast env)
- (switch-mal-type ast
- (types:symbol (lookup-env ast env))
- (types:list (eval-sequence ast env))
- (types:vector (make-mal-vector (apply 'vector (eval-sequence ast env))))
- (types:hash-map (eval-hash-map ast env ))
- (types:any ast)))
-
-(defun rep (string)
- (handler-case
- (mal-print (mal-eval (mal-read string)
- *repl-env*))
- (reader:eof (condition)
- (format nil
- "~a"
- condition))
- (env:undefined-symbol (condition)
- (format nil
- "~a"
- condition))))
-
-;; Readline setup
-;;; The test runner sets this environment variable, in which case we do
-;;; use readline since tests do not work with the readline interface
-(defvar use-readline-p (not (string= (ext:getenv "PERL_RL") "false")))
-
-(defvar *history-file* (namestring (merge-pathnames (user-homedir-pathname)
- ".mal-clisp-history")))
-
-(defun load-history ()
- (readline:read-history *history-file*))
-
-(defun save-history ()
- (readline:write-history *history-file*))
-
-;; Setup history
-(when use-readline-p
- (load-history))
-
-(defun raw-input (prompt)
- (format *standard-output* prompt)
- (force-output *standard-output*)
- (read-line *standard-input* nil))
-
-(defun mal-readline (prompt)
- (let ((input (if use-readline-p
- (readline:readline prompt)
- (raw-input prompt))))
- (when (and use-readline-p
- input
- (not (zerop (length input))))
- (readline:add-history input))
- input))
-
-(defun mal-writeline (string)
- (when string
- (write-line string)))
-
-(defun main ()
- (loop do (let ((line (mal-readline "user> ")))
- (if line
- (mal-writeline (rep line))
- (return))))
- (when use-readline-p
- (save-history)))
-
-;; Do not start REPL inside Emacs
-(unless (member :swank *features*)
- (main))
+++ /dev/null
-(require "dependencies")
-
-(defpackage :mal
- (:use :common-lisp
- :readline
- :types
- :env
- :reader
- :printer))
-
-(in-package :mal)
-
-(defvar *repl-env* (env:create-mal-env))
-
-(set-env *repl-env*
- (types:make-mal-symbol "+")
- (types:make-mal-builtin-fn (lambda (value1 value2)
- (apply-unwrapped-values '+ value1 value2))))
-
-(set-env *repl-env*
- (types:make-mal-symbol "-")
- (types:make-mal-builtin-fn (lambda (value1 value2)
- (apply-unwrapped-values '- value1 value2))))
-
-(set-env *repl-env*
- (types:make-mal-symbol "*")
- (types:make-mal-builtin-fn (lambda (value1 value2)
- (apply-unwrapped-values '* value1 value2))))
-
-(set-env *repl-env*
- (types:make-mal-symbol "/")
- (types:make-mal-builtin-fn (lambda (value1 value2)
- (apply-unwrapped-values '/ value1 value2))))
-
-(defvar mal-def! (make-mal-symbol "def!"))
-(defvar mal-let* (make-mal-symbol "let*"))
-
-(defun eval-sequence (sequence env)
- (map 'list
- (lambda (ast) (mal-eval ast env))
- (mal-data-value sequence)))
-
-(defun eval-hash-map (hash-map env)
- (let ((hash-map-value (mal-data-value hash-map))
- (new-hash-table (make-hash-table :test 'types:mal-value=)))
- (loop
- for key being the hash-keys of hash-map-value
- do (setf (gethash key new-hash-table)
- (mal-eval (gethash key hash-map-value) env)))
- (make-mal-hash-map new-hash-table)))
-
-(defun eval-ast (ast env)
- (switch-mal-type ast
- (types:symbol (env:get-env env ast))
- (types:list (eval-sequence ast env))
- (types:vector (make-mal-vector (apply 'vector (eval-sequence ast env))))
- (types:hash-map (eval-hash-map ast env ))
- (types:any ast)))
-
-(defun eval-let* (forms env)
- (let ((new-env (env:create-mal-env :parent env))
- ;; Convert a potential vector to a list
- (bindings (map 'list
- #'identity
- (types:mal-data-value (second forms)))))
-
- (mapcar (lambda (binding)
- (env:set-env new-env
- (car binding)
- (mal-eval (or (cdr binding)
- types:mal-nil)
- new-env)))
- (loop
- for (symbol value) on bindings
- by #'cddr
- collect (cons symbol value)))
-
- (mal-eval (third forms) new-env)))
-
-(defun eval-list (ast env)
- (let ((forms (mal-data-value ast)))
- (cond
- ((mal-value= mal-def! (first forms))
- (env:set-env env (second forms) (mal-eval (third forms) env)))
- ((mal-value= mal-let* (first forms))
- (eval-let* forms env))
- (t (let ((evaluated-list (eval-ast ast env)))
- (apply (types:mal-data-value (car evaluated-list))
- (cdr evaluated-list)))))))
-
-(defun mal-read (string)
- (reader:read-str string))
-
-(defun mal-eval (ast env)
- (cond
- ((null ast) types:mal-nil)
- ((not (types:mal-list-p ast)) (eval-ast ast env))
- ((zerop (length (mal-data-value ast))) ast)
- (t (eval-list ast env))))
-
-(defun mal-print (expression)
- (printer:pr-str expression))
-
-(defun rep (string)
- (handler-case
- (mal-print (mal-eval (mal-read string)
- *repl-env*))
- (reader:eof (condition)
- (format nil
- "~a"
- condition))
- (env:undefined-symbol (condition)
- (format nil
- "~a"
- condition))))
-
-;; Readline setup
-;;; The test runner sets this environment variable, in which case we do
-;;; use readline since tests do not work with the readline interface
-(defvar use-readline-p (not (string= (ext:getenv "PERL_RL") "false")))
-
-(defvar *history-file* (namestring (merge-pathnames (user-homedir-pathname)
- ".mal-clisp-history")))
-
-(defun load-history ()
- (readline:read-history *history-file*))
-
-(defun save-history ()
- (readline:write-history *history-file*))
-
-;; Setup history
-(when use-readline-p
- (load-history))
-
-(defun raw-input (prompt)
- (format *standard-output* prompt)
- (force-output *standard-output*)
- (read-line *standard-input* nil))
-
-(defun mal-readline (prompt)
- (let ((input (if use-readline-p
- (readline:readline prompt)
- (raw-input prompt))))
- (when (and use-readline-p
- input
- (not (zerop (length input))))
- (readline:add-history input))
- input))
-
-(defun mal-writeline (string)
- (when string
- (write-line string)))
-
-(defun main ()
- (loop do (let ((line (mal-readline "user> ")))
- (if line
- (mal-writeline (rep line))
- (return))))
- (when use-readline-p
- (save-history)))
-
-;; Do not start REPL inside Emacs
-(unless (member :swank *features*)
- (main))
+++ /dev/null
-(require "dependencies")
-
-(defpackage :mal
- (:use :common-lisp
- :readline
- :types
- :env
- :reader
- :printer
- :core))
-
-(in-package :mal)
-
-(defvar *repl-env* (env:create-mal-env))
-
-(dolist (binding core:ns)
- (env:set-env *repl-env*
- (car binding)
- (cdr binding)))
-
-(defvar mal-def! (make-mal-symbol "def!"))
-(defvar mal-let* (make-mal-symbol "let*"))
-(defvar mal-do (make-mal-symbol "do"))
-(defvar mal-if (make-mal-symbol "if"))
-(defvar mal-fn* (make-mal-symbol "fn*"))
-
-(defun eval-sequence (sequence env)
- (map 'list
- (lambda (ast) (mal-eval ast env))
- (mal-data-value sequence)))
-
-(defun eval-hash-map (hash-map env)
- (let ((hash-map-value (mal-data-value hash-map))
- (new-hash-table (make-hash-table :test 'types:mal-value=)))
- (loop
- for key being the hash-keys of hash-map-value
- do (setf (gethash key new-hash-table)
- (mal-eval (gethash key hash-map-value) env)))
- (make-mal-hash-map new-hash-table)))
-
-(defun eval-ast (ast env)
- (switch-mal-type ast
- (types:symbol (env:get-env env ast))
- (types:list (eval-sequence ast env))
- (types:vector (make-mal-vector (apply 'vector (eval-sequence ast env))))
- (types:hash-map (eval-hash-map ast env))
- (types:any ast)))
-
-(defun eval-let* (forms env)
- (let ((new-env (env:create-mal-env :parent env))
- ;; Convert a potential vector to a list
- (bindings (map 'list
- #'identity
- (mal-data-value (second forms)))))
-
- (mapcar (lambda (binding)
- (env:set-env new-env
- (car binding)
- (mal-eval (or (cdr binding)
- types:mal-nil)
- new-env)))
- (loop
- for (symbol value) on bindings
- by #'cddr
- collect (cons symbol value)))
-
- (mal-eval (third forms) new-env)))
-
-(defun eval-list (ast env)
- (let ((forms (mal-data-value ast)))
- (cond
- ((mal-value= mal-def! (first forms))
- (env:set-env env (second forms) (mal-eval (third forms) env)))
- ((mal-value= mal-let* (first forms))
- (eval-let* forms env))
- ((mal-value= mal-do (first forms))
- (car (last (mapcar (lambda (form) (mal-eval form env))
- (cdr forms)))))
- ((mal-value= mal-if (first forms))
- (let ((predicate (mal-eval (second forms) env)))
- (mal-eval (if (or (mal-value= predicate types:mal-nil)
- (mal-value= predicate types:mal-false))
- (fourth forms)
- (third forms))
- env)))
- ((mal-value= mal-fn* (first forms))
- (types:make-mal-fn (let ((arglist (second forms))
- (body (third forms)))
- (lambda (&rest args)
- (mal-eval body (env:create-mal-env :parent env
- :binds (map 'list
- #'identity
- (mal-data-value arglist))
- :exprs args))))))
- (t (let* ((evaluated-list (eval-ast ast env))
- (function (car evaluated-list)))
- ;; If first element is a mal function unwrap it
- (apply (mal-data-value function)
- (cdr evaluated-list)))))))
-
-(defun mal-read (string)
- (reader:read-str string))
-
-(defun mal-eval (ast env)
- (cond
- ((null ast) types:mal-nil)
- ((not (types:mal-list-p ast)) (eval-ast ast env))
- ((zerop (length (mal-data-value ast))) ast)
- (t (eval-list ast env))))
-
-(defun mal-print (expression)
- (printer:pr-str expression))
-
-(defun rep (string)
- (handler-case
- (mal-print (mal-eval (mal-read string)
- *repl-env*))
- (reader:eof (condition)
- (format nil
- "~a"
- condition))
- (env:undefined-symbol (condition)
- (format nil
- "~a"
- condition))
- (error (condition)
- (format nil
- "~a"
- condition))))
-
-(rep "(def! not (fn* (a) (if a false true)))")
-
-;; Readline setup
-;;; The test runner sets this environment variable, in which case we do
-;;; use readline since tests do not work with the readline interface
-(defvar use-readline-p (not (string= (ext:getenv "PERL_RL") "false")))
-
-(defvar *history-file* (namestring (merge-pathnames (user-homedir-pathname)
- ".mal-clisp-history")))
-
-(defun load-history ()
- (readline:read-history *history-file*))
-
-(defun save-history ()
- (readline:write-history *history-file*))
-
-;; Setup history
-(when use-readline-p
- (load-history))
-
-(defun raw-input (prompt)
- (format *standard-output* prompt)
- (force-output *standard-output*)
- (read-line *standard-input* nil))
-
-(defun mal-readline (prompt)
- (let ((input (if use-readline-p
- (readline:readline prompt)
- (raw-input prompt))))
- (when (and use-readline-p
- input
- (not (zerop (length input))))
- (readline:add-history input))
- input))
-
-(defun mal-writeline (string)
- (when string
- (write-line string)))
-
-(defun main ()
- (loop do (let ((line (mal-readline "user> ")))
- (if line
- (mal-writeline (rep line))
- (return))))
- (when use-readline-p
- (save-history)))
-
-;; Do not start REPL inside Emacs
-(unless (member :swank *features*)
- (main))
+++ /dev/null
-(require "dependencies")
-
-(defpackage :mal
- (:use :common-lisp
- :readline
- :types
- :env
- :reader
- :printer
- :core))
-
-(in-package :mal)
-
-(defvar *repl-env* (env:create-mal-env))
-
-(dolist (binding core:ns)
- (env:set-env *repl-env*
- (car binding)
- (cdr binding)))
-
-(defvar mal-def! (make-mal-symbol "def!"))
-(defvar mal-let* (make-mal-symbol "let*"))
-(defvar mal-do (make-mal-symbol "do"))
-(defvar mal-if (make-mal-symbol "if"))
-(defvar mal-fn* (make-mal-symbol "fn*"))
-
-(defun eval-sequence (sequence env)
- (map 'list
- (lambda (ast) (mal-eval ast env))
- (mal-data-value sequence)))
-
-(defun eval-hash-map (hash-map env)
- (let ((hash-map-value (mal-data-value hash-map))
- (new-hash-table (make-hash-table :test 'types:mal-value=)))
- (loop
- for key being the hash-keys of hash-map-value
- do (setf (gethash key new-hash-table)
- (mal-eval (gethash key hash-map-value) env)))
- (make-mal-hash-map new-hash-table)))
-
-(defun eval-ast (ast env)
- (switch-mal-type ast
- (types:symbol (env:get-env env ast))
- (types:list (eval-sequence ast env))
- (types:vector (make-mal-vector (apply 'vector (eval-sequence ast env))))
- (types:hash-map (eval-hash-map ast env))
- (types:any ast)))
-
-(defun mal-read (string)
- (reader:read-str string))
-
-(defun mal-eval (ast env)
- (loop
- do (cond
- ((null ast) (return types:mal-nil))
- ((not (types:mal-list-p ast)) (return (eval-ast ast env)))
- ((zerop (length (mal-data-value ast))) (return ast))
- (t (let ((forms (mal-data-value ast)))
- (cond
- ((mal-value= mal-def! (first forms))
- (return (env:set-env env (second forms) (mal-eval (third forms) env))))
-
- ((mal-value= mal-let* (first forms))
- (let ((new-env (env:create-mal-env :parent env))
- ;; Convert a potential vector to a list
- (bindings (map 'list
- #'identity
- (mal-data-value (second forms)))))
-
- (mapcar (lambda (binding)
- (env:set-env new-env
- (car binding)
- (mal-eval (or (cdr binding)
- types:mal-nil)
- new-env)))
- (loop
- for (symbol value) on bindings
- by #'cddr
- collect (cons symbol value)))
- (setf ast (third forms)
- env new-env)))
-
- ((mal-value= mal-do (first forms))
- (mapc (lambda (form) (mal-eval form env))
- (butlast (cdr forms)))
- (setf ast (car (last forms))))
-
- ((mal-value= mal-if (first forms))
- (let ((predicate (mal-eval (second forms) env)))
- (setf ast (if (or (mal-value= predicate types:mal-nil)
- (mal-value= predicate types:mal-false))
- (fourth forms)
- (third forms)))))
-
- ((mal-value= mal-fn* (first forms))
- (return (let ((arglist (second forms))
- (body (third forms)))
- (types:make-mal-fn (lambda (&rest args)
- (mal-eval body (env:create-mal-env :parent env
- :binds (map 'list
- #'identity
- (mal-data-value arglist))
- :exprs args)))
- :attrs (list (cons 'params arglist)
- (cons 'ast body)
- (cons 'env env))))))
-
- (t (let* ((evaluated-list (eval-ast ast env))
- (function (car evaluated-list)))
- ;; If first element is a mal function unwrap it
- (if (not (types:mal-fn-p function))
- (return (apply (mal-data-value function)
- (cdr evaluated-list)))
- (let* ((attrs (types:mal-data-attrs function)))
- (setf ast (cdr (assoc 'ast attrs))
- env (env:create-mal-env :parent (cdr (assoc 'env attrs))
- :binds (map 'list
- #'identity
- (mal-data-value (cdr (assoc 'params attrs))))
- :exprs (cdr evaluated-list)))))))))))))
-
-(defun mal-print (expression)
- (printer:pr-str expression))
-
-(defun rep (string)
- (handler-case
- (mal-print (mal-eval (mal-read string)
- *repl-env*))
- (reader:eof (condition)
- (format nil
- "~a"
- condition))
- (env:undefined-symbol (condition)
- (format nil
- "~a"
- condition))
- (error (condition)
- (format nil
- "~a"
- condition))))
-
-(rep "(def! not (fn* (a) (if a false true)))")
-
-;; Readline setup
-;;; The test runner sets this environment variable, in which case we do
-;;; use readline since tests do not work with the readline interface
-(defvar use-readline-p (not (string= (ext:getenv "PERL_RL") "false")))
-
-(defvar *history-file* (namestring (merge-pathnames (user-homedir-pathname)
- ".mal-clisp-history")))
-
-(defun load-history ()
- (readline:read-history *history-file*))
-
-(defun save-history ()
- (readline:write-history *history-file*))
-
-;; Setup history
-(when use-readline-p
- (load-history))
-
-(defun raw-input (prompt)
- (format *standard-output* prompt)
- (force-output *standard-output*)
- (read-line *standard-input* nil))
-
-(defun mal-readline (prompt)
- (let ((input (if use-readline-p
- (readline:readline prompt)
- (raw-input prompt))))
- (when (and use-readline-p
- input
- (not (zerop (length input))))
- (readline:add-history input))
- input))
-
-(defun mal-writeline (string)
- (when string
- (write-line string)))
-
-(defun main ()
- (loop do (let ((line (mal-readline "user> ")))
- (if line
- (mal-writeline (rep line))
- (return))))
- (when use-readline-p
- (save-history)))
-
-;; Do not start REPL inside Emacs
-(unless (member :swank *features*)
- (main))
+++ /dev/null
-(require "dependencies")
-
-(defpackage :mal
- (:use :common-lisp
- :readline
- :types
- :env
- :reader
- :printer
- :core))
-
-(in-package :mal)
-
-(defvar *repl-env* (env:create-mal-env))
-
-(dolist (binding core:ns)
- (env:set-env *repl-env*
- (car binding)
- (cdr binding)))
-
-(defvar mal-def! (make-mal-symbol "def!"))
-(defvar mal-let* (make-mal-symbol "let*"))
-(defvar mal-do (make-mal-symbol "do"))
-(defvar mal-if (make-mal-symbol "if"))
-(defvar mal-fn* (make-mal-symbol "fn*"))
-
-(env:set-env *repl-env*
- (types:make-mal-symbol "eval")
- (types:make-mal-builtin-fn (lambda (ast)
- (mal-eval ast *repl-env*))))
-
-(defun eval-sequence (sequence env)
- (map 'list
- (lambda (ast) (mal-eval ast env))
- (mal-data-value sequence)))
-
-(defun eval-hash-map (hash-map env)
- (let ((hash-map-value (mal-data-value hash-map))
- (new-hash-table (make-hash-table :test 'types:mal-value=)))
- (loop
- for key being the hash-keys of hash-map-value
- do (setf (gethash (mal-eval key env) new-hash-table)
- (mal-eval (gethash key hash-map-value) env)))
- (make-mal-hash-map new-hash-table)))
-
-(defun eval-ast (ast env)
- (switch-mal-type ast
- (types:symbol (env:get-env env ast))
- (types:list (eval-sequence ast env))
- (types:vector (make-mal-vector (apply 'vector (eval-sequence ast env))))
- (types:hash-map (eval-hash-map ast env))
- (types:any ast)))
-
-(defun mal-read (string)
- (reader:read-str string))
-
-(defun mal-eval (ast env)
- (loop
- do (cond
- ((null ast) (return types:mal-nil))
- ((not (types:mal-list-p ast)) (return (eval-ast ast env)))
- ((zerop (length (mal-data-value ast))) (return ast))
- (t (let ((forms (mal-data-value ast)))
- (cond
- ((mal-value= mal-def! (first forms))
- (return (env:set-env env (second forms) (mal-eval (third forms) env))))
-
- ((mal-value= mal-let* (first forms))
- (let ((new-env (env:create-mal-env :parent env))
- ;; Convert a potential vector to a list
- (bindings (map 'list
- #'identity
- (mal-data-value (second forms)))))
-
- (mapcar (lambda (binding)
- (env:set-env new-env
- (car binding)
- (mal-eval (or (cdr binding)
- types:mal-nil)
- new-env)))
- (loop
- for (symbol value) on bindings
- by #'cddr
- collect (cons symbol value)))
- (setf ast (third forms)
- env new-env)))
-
- ((mal-value= mal-do (first forms))
- (mapc (lambda (form) (mal-eval form env))
- (butlast (cdr forms)))
- (setf ast (car (last forms))))
-
- ((mal-value= mal-if (first forms))
- (let ((predicate (mal-eval (second forms) env)))
- (setf ast (if (or (mal-value= predicate types:mal-nil)
- (mal-value= predicate types:mal-false))
- (fourth forms)
- (third forms)))))
-
- ((mal-value= mal-fn* (first forms))
- (return (let ((arglist (second forms))
- (body (third forms)))
- (types:make-mal-fn (lambda (&rest args)
- (mal-eval body (env:create-mal-env :parent env
- :binds (map 'list
- #'identity
- (mal-data-value arglist))
- :exprs args)))
- :attrs (list (cons 'params arglist)
- (cons 'ast body)
- (cons 'env env))))))
-
- (t (let* ((evaluated-list (eval-ast ast env))
- (function (car evaluated-list)))
- ;; If first element is a mal function unwrap it
- (if (not (types:mal-fn-p function))
- (return (apply (mal-data-value function)
- (cdr evaluated-list)))
- (let* ((attrs (types:mal-data-attrs function)))
- (setf ast (cdr (assoc 'ast attrs))
- env (env:create-mal-env :parent (cdr (assoc 'env attrs))
- :binds (map 'list
- #'identity
- (mal-data-value (cdr (assoc 'params attrs))))
- :exprs (cdr evaluated-list)))))))))))))
-
-(defun mal-print (expression)
- (printer:pr-str expression))
-
-(defun rep (string)
- (handler-case
- (mal-print (mal-eval (mal-read string)
- *repl-env*))
- (reader:eof (condition)
- (format nil
- "~a"
- condition))
- (env:undefined-symbol (condition)
- (format nil
- "~a"
- condition))
- (error (condition)
- (format nil
- "~a"
- condition))))
-
-(rep "(def! not (fn* (a) (if a false true)))")
-(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))")
-(rep "(def! *ARGV* (list))")
-
-(env:set-env *repl-env*
- (types:make-mal-symbol "*ARGV*")
- (types:wrap-value (cdr common-lisp-user::*args*)
- :listp t))
-
-;; Readline setup
-;;; The test runner sets this environment variable, in which case we do
-;;; use readline since tests do not work with the readline interface
-(defvar use-readline-p (not (string= (ext:getenv "PERL_RL") "false")))
-
-(defvar *history-file* (namestring (merge-pathnames (user-homedir-pathname)
- ".mal-clisp-history")))
-
-(defun load-history ()
- (readline:read-history *history-file*))
-
-(defun save-history ()
- (readline:write-history *history-file*))
-
-;; Setup history
-(when use-readline-p
- (load-history))
-
-(defun raw-input (prompt)
- (format *standard-output* prompt)
- (force-output *standard-output*)
- (read-line *standard-input* nil))
-
-(defun mal-readline (prompt)
- (let ((input (if use-readline-p
- (readline:readline prompt)
- (raw-input prompt))))
- (when (and use-readline-p
- input
- (not (zerop (length input))))
- (readline:add-history input))
- input))
-
-(defun mal-writeline (string)
- (when string
- (write-line string)))
-
-(defun repl ()
- (loop do (let ((line (mal-readline "user> ")))
- (if line
- (mal-writeline (rep line))
- (return))))
- (when use-readline-p
- (save-history)))
-
-(defun main ()
- (if (null common-lisp-user::*args*)
- ;; Do not start REPL inside Emacs
- (unless (member :swank *features*)
- (repl))
- (rep (format nil
- "(load-file \"~a\")"
- (car common-lisp-user::*args*)))))
-
-(main)
+++ /dev/null
-(require "dependencies")
-
-(defpackage :mal
- (:use :common-lisp
- :readline
- :types
- :env
- :reader
- :printer
- :core))
-
-(in-package :mal)
-
-(defvar *repl-env* (env:create-mal-env))
-
-(dolist (binding core:ns)
- (env:set-env *repl-env*
- (car binding)
- (cdr binding)))
-
-(defvar mal-quote (make-mal-symbol "quote"))
-(defvar mal-quasiquote (make-mal-symbol "quasiquote"))
-(defvar mal-unquote (make-mal-symbol "unquote"))
-(defvar mal-splice-unquote (make-mal-symbol "splice-unquote"))
-(defvar mal-cons (make-mal-symbol "cons"))
-(defvar mal-concat (make-mal-symbol "concat"))
-(defvar mal-def! (make-mal-symbol "def!"))
-(defvar mal-let* (make-mal-symbol "let*"))
-(defvar mal-do (make-mal-symbol "do"))
-(defvar mal-if (make-mal-symbol "if"))
-(defvar mal-fn* (make-mal-symbol "fn*"))
-
-(env:set-env *repl-env*
- (types:make-mal-symbol "eval")
- (types:make-mal-builtin-fn (lambda (ast)
- (mal-eval ast *repl-env*))))
-
-(defun eval-sequence (sequence env)
- (map 'list
- (lambda (ast) (mal-eval ast env))
- (mal-data-value sequence)))
-
-(defun eval-hash-map (hash-map env)
- (let ((hash-map-value (mal-data-value hash-map))
- (new-hash-table (make-hash-table :test 'types:mal-value=)))
- (loop
- for key being the hash-keys of hash-map-value
- do (setf (gethash (mal-eval key env) new-hash-table)
- (mal-eval (gethash key hash-map-value) env)))
- (make-mal-hash-map new-hash-table)))
-
-(defun eval-ast (ast env)
- (switch-mal-type ast
- (types:symbol (env:get-env env ast))
- (types:list (eval-sequence ast env))
- (types:vector (make-mal-vector (apply 'vector (eval-sequence ast env))))
- (types:hash-map (eval-hash-map ast env))
- (types:any ast)))
-
-
-(defun is-pair (value)
- (and (or (mal-list-p value)
- (mal-vector-p value))
- (not (zerop (length (mal-data-value value))))))
-
-(defun quasiquote (ast)
- (if (not (is-pair ast))
- (types:make-mal-list (list mal-quote
- ast))
- (let ((forms (map 'list #'identity (mal-data-value ast))))
- (cond
- ((mal-value= mal-unquote (first forms))
- (second forms))
-
- ((and (is-pair (first forms))
- (mal-value= mal-splice-unquote
- (first (mal-data-value (first forms)))))
- (types:make-mal-list (list mal-concat
- (second (mal-data-value (first forms)))
- (quasiquote (make-mal-list (cdr forms))))))
-
- (t (types:make-mal-list (list mal-cons
- (quasiquote (first forms))
- (quasiquote (make-mal-list (cdr forms))))))))))
-
-(defun mal-read (string)
- (reader:read-str string))
-
-(defun mal-eval (ast env)
- (loop
- do (cond
- ((null ast) (return types:mal-nil))
- ((not (types:mal-list-p ast)) (return (eval-ast ast env)))
- ((zerop (length (mal-data-value ast))) (return ast))
- (t (let ((forms (mal-data-value ast)))
- (cond
- ((mal-value= mal-quote (first forms))
- (return (second forms)))
-
- ((mal-value= mal-quasiquote (first forms))
- (setf ast (quasiquote (second forms))))
-
- ((mal-value= mal-def! (first forms))
- (return (env:set-env env (second forms) (mal-eval (third forms) env))))
-
- ((mal-value= mal-let* (first forms))
- (let ((new-env (env:create-mal-env :parent env))
- ;; Convert a potential vector to a list
- (bindings (map 'list
- #'identity
- (mal-data-value (second forms)))))
-
- (mapcar (lambda (binding)
- (env:set-env new-env
- (car binding)
- (mal-eval (or (cdr binding)
- types:mal-nil)
- new-env)))
- (loop
- for (symbol value) on bindings
- by #'cddr
- collect (cons symbol value)))
- (setf ast (third forms)
- env new-env)))
-
- ((mal-value= mal-do (first forms))
- (mapc (lambda (form) (mal-eval form env))
- (butlast (cdr forms)))
- (setf ast (car (last forms))))
-
- ((mal-value= mal-if (first forms))
- (let ((predicate (mal-eval (second forms) env)))
- (setf ast (if (or (mal-value= predicate types:mal-nil)
- (mal-value= predicate types:mal-false))
- (fourth forms)
- (third forms)))))
-
- ((mal-value= mal-fn* (first forms))
- (return (let ((arglist (second forms))
- (body (third forms)))
- (types:make-mal-fn (lambda (&rest args)
- (mal-eval body (env:create-mal-env :parent env
- :binds (map 'list
- #'identity
- (mal-data-value arglist))
- :exprs args)))
- :attrs (list (cons 'params arglist)
- (cons 'ast body)
- (cons 'env env))))))
-
- (t (let* ((evaluated-list (eval-ast ast env))
- (function (car evaluated-list)))
- ;; If first element is a mal function unwrap it
- (if (not (types:mal-fn-p function))
- (return (apply (mal-data-value function)
- (cdr evaluated-list)))
- (let* ((attrs (types:mal-data-attrs function)))
- (setf ast (cdr (assoc 'ast attrs))
- env (env:create-mal-env :parent (cdr (assoc 'env attrs))
- :binds (map 'list
- #'identity
- (mal-data-value (cdr (assoc 'params attrs))))
- :exprs (cdr evaluated-list)))))))))))))
-
-(defun mal-print (expression)
- (printer:pr-str expression))
-
-(defun rep (string)
- (handler-case
- (mal-print (mal-eval (mal-read string)
- *repl-env*))
- (reader:eof (condition)
- (format nil
- "~a"
- condition))
- (env:undefined-symbol (condition)
- (format nil
- "~a"
- condition))
- (error (condition)
- (format nil
- "~a"
- condition))))
-
-(rep "(def! not (fn* (a) (if a false true)))")
-(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))")
-(rep "(def! *ARGV* (list))")
-
-(env:set-env *repl-env*
- (types:make-mal-symbol "*ARGV*")
- (types:wrap-value (cdr common-lisp-user::*args*)
- :listp t))
-
-;; Readline setup
-;;; The test runner sets this environment variable, in which case we do
-;;; use readline since tests do not work with the readline interface
-(defvar use-readline-p (not (string= (ext:getenv "PERL_RL") "false")))
-
-(defvar *history-file* (namestring (merge-pathnames (user-homedir-pathname)
- ".mal-clisp-history")))
-
-(defun load-history ()
- (readline:read-history *history-file*))
-
-(defun save-history ()
- (readline:write-history *history-file*))
-
-;; Setup history
-(when use-readline-p
- (load-history))
-
-(defun raw-input (prompt)
- (format *standard-output* prompt)
- (force-output *standard-output*)
- (read-line *standard-input* nil))
-
-(defun mal-readline (prompt)
- (let ((input (if use-readline-p
- (readline:readline prompt)
- (raw-input prompt))))
- (when (and use-readline-p
- input
- (not (zerop (length input))))
- (readline:add-history input))
- input))
-
-(defun mal-writeline (string)
- (when string
- (write-line string)))
-
-(defun repl ()
- (loop do (let ((line (mal-readline "user> ")))
- (if line
- (mal-writeline (rep line))
- (return))))
- (when use-readline-p
- (save-history)))
-
-(defun main ()
- (if (null common-lisp-user::*args*)
- ;; Do not start REPL inside Emacs
- (unless (member :swank *features*)
- (repl))
- (rep (format nil
- "(load-file \"~a\")"
- (car common-lisp-user::*args*)))))
-
-(main)
+++ /dev/null
-(require "dependencies")
-
-(defpackage :mal
- (:use :common-lisp
- :readline
- :types
- :env
- :reader
- :printer
- :core))
-
-(in-package :mal)
-
-(define-condition invalid-function (types:mal-error)
- ((form :initarg :form :reader form)
- (context :initarg :context :reader context))
- (:report (lambda (condition stream)
- (format stream
- "Invalid function '~a' provided while ~a"
- (printer:pr-str (form condition))
- (if (string= (context condition) "apply")
- "applying"
- "defining macro")))))
-
-(defvar *repl-env* (env:create-mal-env))
-
-(dolist (binding core:ns)
- (env:set-env *repl-env*
- (car binding)
- (cdr binding)))
-
-(defvar mal-quote (make-mal-symbol "quote"))
-(defvar mal-quasiquote (make-mal-symbol "quasiquote"))
-(defvar mal-unquote (make-mal-symbol "unquote"))
-(defvar mal-splice-unquote (make-mal-symbol "splice-unquote"))
-(defvar mal-cons (make-mal-symbol "cons"))
-(defvar mal-concat (make-mal-symbol "concat"))
-(defvar mal-macroexpand (make-mal-symbol "macroexpand"))
-(defvar mal-def! (make-mal-symbol "def!"))
-(defvar mal-defmacro! (make-mal-symbol "defmacro!"))
-(defvar mal-let* (make-mal-symbol "let*"))
-(defvar mal-do (make-mal-symbol "do"))
-(defvar mal-if (make-mal-symbol "if"))
-(defvar mal-fn* (make-mal-symbol "fn*"))
-
-(env:set-env *repl-env*
- (types:make-mal-symbol "eval")
- (types:make-mal-builtin-fn (lambda (ast)
- (mal-eval ast *repl-env*))))
-
-(defun eval-sequence (sequence env)
- (map 'list
- (lambda (ast) (mal-eval ast env))
- (mal-data-value sequence)))
-
-(defun eval-hash-map (hash-map env)
- (let ((hash-map-value (mal-data-value hash-map))
- (new-hash-table (make-hash-table :test 'types:mal-value=)))
- (loop
- for key being the hash-keys of hash-map-value
- do (setf (gethash (mal-eval key env) new-hash-table)
- (mal-eval (gethash key hash-map-value) env)))
- (make-mal-hash-map new-hash-table)))
-
-(defun eval-ast (ast env)
- (switch-mal-type ast
- (types:symbol (env:get-env env ast))
- (types:list (eval-sequence ast env))
- (types:vector (make-mal-vector (apply 'vector (eval-sequence ast env))))
- (types:hash-map (eval-hash-map ast env))
- (types:any ast)))
-
-(defun is-pair (value)
- (and (or (mal-list-p value)
- (mal-vector-p value))
- (not (zerop (length (mal-data-value value))))))
-
-(defun quasiquote (ast)
- (if (not (is-pair ast))
- (types:make-mal-list (list mal-quote
- ast))
- (let ((forms (map 'list #'identity (mal-data-value ast))))
- (cond
- ((mal-value= mal-unquote (first forms))
- (second forms))
-
- ((and (is-pair (first forms))
- (mal-value= mal-splice-unquote
- (first (mal-data-value (first forms)))))
- (types:make-mal-list (list mal-concat
- (second (mal-data-value (first forms)))
- (quasiquote (make-mal-list (cdr forms))))))
-
- (t (types:make-mal-list (list mal-cons
- (quasiquote (first forms))
- (quasiquote (make-mal-list (cdr forms))))))))))
-
-(defun is-macro-call (ast env)
- (when (and (types:mal-list-p ast)
- (not (zerop (length (mal-data-value ast)))))
- (let* ((func-symbol (first (mal-data-value ast)))
- (func (when (types:mal-symbol-p func-symbol)
- (env:find-env env func-symbol))))
- (and func
- (types:mal-fn-p func)
- (cdr (assoc 'is-macro (types:mal-data-attrs func)))))))
-
-(defun mal-macroexpand (ast env)
- (loop
- while (is-macro-call ast env)
- do (let* ((forms (types:mal-data-value ast))
- (func (env:get-env env (first forms))))
- (setf ast (apply (mal-data-value func)
- (cdr forms)))))
- ast)
-
-(defun mal-eval (ast env)
- (loop
- do (setf ast (mal-macroexpand ast env))
- do (cond
- ((null ast) (return types:mal-nil))
- ((not (types:mal-list-p ast)) (return (eval-ast ast env)))
- ((zerop (length (mal-data-value ast))) (return ast))
- (t (let ((forms (mal-data-value ast)))
- (cond
- ((mal-value= mal-quote (first forms))
- (return (second forms)))
-
- ((mal-value= mal-quasiquote (first forms))
- (setf ast (quasiquote (second forms))))
-
- ((mal-value= mal-macroexpand (first forms))
- (return (mal-macroexpand (second forms) env)))
-
- ((mal-value= mal-def! (first forms))
- (return (env:set-env env (second forms) (mal-eval (third forms) env))))
-
- ((mal-value= mal-defmacro! (first forms))
- (let ((value (mal-eval (third forms) env)))
- (return (if (types:mal-fn-p value)
- (env:set-env env
- (second forms)
- (progn
- (setf (cdr (assoc 'is-macro (types:mal-data-attrs value))) t)
- value))
- (error 'invalid-function
- :form value
- :context "macro")))))
-
- ((mal-value= mal-let* (first forms))
- (let ((new-env (env:create-mal-env :parent env))
- ;; Convert a potential vector to a list
- (bindings (map 'list
- #'identity
- (mal-data-value (second forms)))))
-
- (mapcar (lambda (binding)
- (env:set-env new-env
- (car binding)
- (mal-eval (or (cdr binding)
- types:mal-nil)
- new-env)))
- (loop
- for (symbol value) on bindings
- by #'cddr
- collect (cons symbol value)))
- (setf ast (third forms)
- env new-env)))
-
- ((mal-value= mal-do (first forms))
- (mapc (lambda (form) (mal-eval form env))
- (butlast (cdr forms)))
- (setf ast (car (last forms))))
-
- ((mal-value= mal-if (first forms))
- (let ((predicate (mal-eval (second forms) env)))
- (setf ast (if (or (mal-value= predicate types:mal-nil)
- (mal-value= predicate types:mal-false))
- (fourth forms)
- (third forms)))))
-
- ((mal-value= mal-fn* (first forms))
- (return (let ((arglist (second forms))
- (body (third forms)))
- (types:make-mal-fn (lambda (&rest args)
- (mal-eval body (env:create-mal-env :parent env
- :binds (map 'list
- #'identity
- (mal-data-value arglist))
- :exprs args)))
- :attrs (list (cons 'params arglist)
- (cons 'ast body)
- (cons 'env env)
- (cons 'is-macro nil))))))
-
- (t (let* ((evaluated-list (eval-ast ast env))
- (function (car evaluated-list)))
- ;; If first element is a mal function unwrap it
- (cond ((types:mal-fn-p function)
- (let* ((attrs (types:mal-data-attrs function)))
- (setf ast (cdr (assoc 'ast attrs))
- env (env:create-mal-env :parent (cdr (assoc 'env attrs))
- :binds (map 'list
- #'identity
- (mal-data-value (cdr (assoc 'params attrs))))
- :exprs (cdr evaluated-list)))))
- ((types:mal-builtin-fn-p function)
- (return (apply (mal-data-value function)
- (cdr evaluated-list))))
- (t (error 'invalid-function
- :form function
- :context "apply")))))))))))
-
-(defun mal-read (string)
- (reader:read-str string))
-
-(defun mal-print (expression)
- (printer:pr-str expression))
-
-(defun rep (string)
- (handler-case
- (mal-print (mal-eval (mal-read string)
- *repl-env*))
- (types:mal-error (condition)
- (format nil
- "~a"
- condition))
- (error (condition)
- (format nil
- "Internal error: ~a"
- condition))))
-
-(rep "(def! not (fn* (a) (if a false true)))")
-(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))")
-(rep "(def! *ARGV* (list))")
-(rep "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))")
-(rep "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))")
-
-(env:set-env *repl-env*
- (types:make-mal-symbol "*ARGV*")
- (types:wrap-value (cdr common-lisp-user::*args*)
- :listp t))
-
-;; Readline setup
-;;; The test runner sets this environment variable, in which case we do
-;;; use readline since tests do not work with the readline interface
-(defvar use-readline-p (not (string= (ext:getenv "PERL_RL") "false")))
-
-(defvar *history-file* (namestring (merge-pathnames (user-homedir-pathname)
- ".mal-clisp-history")))
-
-(defun load-history ()
- (readline:read-history *history-file*))
-
-(defun save-history ()
- (readline:write-history *history-file*))
-
-;; Setup history
-(when use-readline-p
- (load-history))
-
-(defun raw-input (prompt)
- (format *standard-output* prompt)
- (force-output *standard-output*)
- (read-line *standard-input* nil))
-
-(defun mal-readline (prompt)
- (let ((input (if use-readline-p
- (readline:readline prompt)
- (raw-input prompt))))
- (when (and use-readline-p
- input
- (not (zerop (length input))))
- (readline:add-history input))
- input))
-
-(defun mal-writeline (string)
- (when string
- (write-line string)))
-
-(defun repl ()
- (loop do (let ((line (mal-readline "user> ")))
- (if line
- (mal-writeline (rep line))
- (return))))
- (when use-readline-p
- (save-history)))
-
-(defun main ()
- (if (null common-lisp-user::*args*)
- ;; Do not start REPL inside Emacs
- (unless (member :swank *features*)
- (repl))
- (rep (format nil
- "(load-file \"~a\")"
- (car common-lisp-user::*args*)))))
-
-(main)
+++ /dev/null
-(require "dependencies")
-
-(defpackage :mal
- (:use :common-lisp
- :readline
- :types
- :env
- :reader
- :printer
- :core))
-
-(in-package :mal)
-
-(define-condition invalid-function (types:mal-runtime-exception)
- ((form :initarg :form :reader form)
- (context :initarg :context :reader context))
- (:report (lambda (condition stream)
- (format stream
- "Invalid function '~a' provided while ~a"
- (printer:pr-str (form condition))
- (if (string= (context condition) "apply")
- "applying"
- "defining macro")))))
-
-(defvar *repl-env* (env:create-mal-env))
-
-(dolist (binding core:ns)
- (env:set-env *repl-env*
- (car binding)
- (cdr binding)))
-
-(env:set-env *repl-env*
- (types:make-mal-symbol "eval")
- (types:make-mal-builtin-fn (lambda (ast)
- (mal-eval ast *repl-env*))))
-
-(defvar mal-quote (make-mal-symbol "quote"))
-(defvar mal-quasiquote (make-mal-symbol "quasiquote"))
-(defvar mal-unquote (make-mal-symbol "unquote"))
-(defvar mal-splice-unquote (make-mal-symbol "splice-unquote"))
-(defvar mal-cons (make-mal-symbol "cons"))
-(defvar mal-concat (make-mal-symbol "concat"))
-(defvar mal-macroexpand (make-mal-symbol "macroexpand"))
-(defvar mal-def! (make-mal-symbol "def!"))
-(defvar mal-defmacro! (make-mal-symbol "defmacro!"))
-(defvar mal-let* (make-mal-symbol "let*"))
-(defvar mal-do (make-mal-symbol "do"))
-(defvar mal-if (make-mal-symbol "if"))
-(defvar mal-fn* (make-mal-symbol "fn*"))
-(defvar mal-try* (make-mal-symbol "try*"))
-(defvar mal-catch* (make-mal-symbol "catch*"))
-
-(defun eval-sequence (sequence env)
- (map 'list
- (lambda (ast) (mal-eval ast env))
- (mal-data-value sequence)))
-
-(defun eval-hash-map (hash-map env)
- (let ((hash-map-value (mal-data-value hash-map))
- (new-hash-table (make-hash-table :test 'types:mal-value=)))
- (loop
- for key being the hash-keys of hash-map-value
- do (setf (gethash (mal-eval key env) new-hash-table)
- (mal-eval (gethash key hash-map-value) env)))
- (make-mal-hash-map new-hash-table)))
-
-(defun eval-ast (ast env)
- (switch-mal-type ast
- (types:symbol (env:get-env env ast))
- (types:list (eval-sequence ast env))
- (types:vector (make-mal-vector (apply 'vector (eval-sequence ast env))))
- (types:hash-map (eval-hash-map ast env))
- (types:any ast)))
-
-(defun is-pair (value)
- (and (or (mal-list-p value)
- (mal-vector-p value))
- (not (zerop (length (mal-data-value value))))))
-
-(defun quasiquote (ast)
- (if (not (is-pair ast))
- (types:make-mal-list (list mal-quote
- ast))
- (let ((forms (map 'list #'identity (mal-data-value ast))))
- (cond
- ((mal-value= mal-unquote (first forms))
- (second forms))
-
- ((and (is-pair (first forms))
- (mal-value= mal-splice-unquote
- (first (mal-data-value (first forms)))))
- (types:make-mal-list (list mal-concat
- (second (mal-data-value (first forms)))
- (quasiquote (make-mal-list (cdr forms))))))
-
- (t (types:make-mal-list (list mal-cons
- (quasiquote (first forms))
- (quasiquote (make-mal-list (cdr forms))))))))))
-
-(defun is-macro-call (ast env)
- (when (and (types:mal-list-p ast)
- (not (zerop (length (mal-data-value ast)))))
- (let* ((func-symbol (first (mal-data-value ast)))
- (func (when (types:mal-symbol-p func-symbol)
- (env:find-env env func-symbol))))
- (and func
- (types:mal-fn-p func)
- (cdr (assoc 'is-macro (types:mal-data-attrs func)))))))
-
-(defun mal-macroexpand (ast env)
- (loop
- while (is-macro-call ast env)
- do (let* ((forms (types:mal-data-value ast))
- (func (env:get-env env (first forms))))
- (setf ast (apply (mal-data-value func)
- (cdr forms)))))
- ast)
-
-(defun mal-eval (ast env)
- (loop
- do (setf ast (mal-macroexpand ast env))
- do (cond
- ((null ast) (return types:mal-nil))
- ((not (types:mal-list-p ast)) (return (eval-ast ast env)))
- ((zerop (length (mal-data-value ast))) (return ast))
- (t (let ((forms (mal-data-value ast)))
- (cond
- ((mal-value= mal-quote (first forms))
- (return (second forms)))
-
- ((mal-value= mal-quasiquote (first forms))
- (setf ast (quasiquote (second forms))))
-
- ((mal-value= mal-macroexpand (first forms))
- (return (mal-macroexpand (second forms) env)))
-
- ((mal-value= mal-def! (first forms))
- (return (env:set-env env (second forms) (mal-eval (third forms) env))))
-
- ((mal-value= mal-defmacro! (first forms))
- (let ((value (mal-eval (third forms) env)))
- (return (if (types:mal-fn-p value)
- (env:set-env env
- (second forms)
- (progn
- (setf (cdr (assoc 'is-macro (types:mal-data-attrs value))) t)
- value))
- (error 'invalid-function
- :form value
- :context "macro")))))
-
- ((mal-value= mal-let* (first forms))
- (let ((new-env (env:create-mal-env :parent env))
- ;; Convert a potential vector to a list
- (bindings (map 'list
- #'identity
- (mal-data-value (second forms)))))
-
- (mapcar (lambda (binding)
- (env:set-env new-env
- (car binding)
- (mal-eval (or (cdr binding)
- types:mal-nil)
- new-env)))
- (loop
- for (symbol value) on bindings
- by #'cddr
- collect (cons symbol value)))
- (setf ast (third forms)
- env new-env)))
-
- ((mal-value= mal-do (first forms))
- (mapc (lambda (form) (mal-eval form env))
- (butlast (cdr forms)))
- (setf ast (car (last forms))))
-
- ((mal-value= mal-if (first forms))
- (let ((predicate (mal-eval (second forms) env)))
- (setf ast (if (or (mal-value= predicate types:mal-nil)
- (mal-value= predicate types:mal-false))
- (fourth forms)
- (third forms)))))
-
- ((mal-value= mal-fn* (first forms))
- (return (let ((arglist (second forms))
- (body (third forms)))
- (types:make-mal-fn (lambda (&rest args)
- (mal-eval body (env:create-mal-env :parent env
- :binds (map 'list
- #'identity
- (mal-data-value arglist))
- :exprs args)))
- :attrs (list (cons 'params arglist)
- (cons 'ast body)
- (cons 'env env)
- (cons 'is-macro nil))))))
-
- ((mal-value= mal-try* (first forms))
- (handler-case
- (return (mal-eval (second forms) env))
- (types:mal-exception (condition)
- (when (third forms)
- (let ((catch-forms (types:mal-data-value (third forms))))
- (when (mal-value= mal-catch*
- (first catch-forms))
- (return (mal-eval (third catch-forms)
- (env:create-mal-env :parent env
- :binds (list (second catch-forms))
- :exprs (list (if (typep condition 'types:mal-runtime-exception)
- (types:make-mal-string (format nil "~a" condition))
- (types::mal-exception-data condition)))))))))
- (error condition))))
-
- (t (let* ((evaluated-list (eval-ast ast env))
- (function (car evaluated-list)))
- ;; If first element is a mal function unwrap it
- (cond ((types:mal-fn-p function)
- (let* ((attrs (types:mal-data-attrs function)))
- (setf ast (cdr (assoc 'ast attrs))
- env (env:create-mal-env :parent (cdr (assoc 'env attrs))
- :binds (map 'list
- #'identity
- (mal-data-value (cdr (assoc 'params attrs))))
- :exprs (cdr evaluated-list)))))
- ((types:mal-builtin-fn-p function)
- (return (apply (mal-data-value function)
- (cdr evaluated-list))))
- (t (error 'invalid-function
- :form function
- :context "apply")))))))))))
-
-(defun mal-read (string)
- (reader:read-str string))
-
-(defun mal-print (expression)
- (printer:pr-str expression))
-
-(defun rep (string)
- (handler-case
- (mal-print (mal-eval (mal-read string)
- *repl-env*))
- (types:mal-error (condition)
- (format nil
- "Error: ~a"
- condition))
- (types:mal-runtime-exception (condition)
- (format nil
- "Exception: ~a"
- condition))
- (types:mal-user-exception (condition)
- (format nil
- "Exception: ~a"
- (pr-str (types::mal-exception-data condition))))
- (error (condition)
- (format nil
- "Internal error: ~a"
- condition))))
-
-(rep "(def! not (fn* (a) (if a false true)))")
-(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))")
-(rep "(def! *ARGV* (list))")
-(rep "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))")
-(rep "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))")
-
-(env:set-env *repl-env*
- (types:make-mal-symbol "*ARGV*")
- (types:wrap-value (cdr common-lisp-user::*args*)
- :listp t))
-
-;; Readline setup
-;;; The test runner sets this environment variable, in which case we do
-;;; use readline since tests do not work with the readline interface
-(defvar use-readline-p (not (string= (ext:getenv "PERL_RL") "false")))
-
-(defvar *history-file* (namestring (merge-pathnames (user-homedir-pathname)
- ".mal-clisp-history")))
-
-(defun load-history ()
- (readline:read-history *history-file*))
-
-(defun save-history ()
- (readline:write-history *history-file*))
-
-;; Setup history
-(when use-readline-p
- (load-history))
-
-(defun raw-input (prompt)
- (format *standard-output* prompt)
- (force-output *standard-output*)
- (read-line *standard-input* nil))
-
-(defun mal-readline (prompt)
- (let ((input (if use-readline-p
- (readline:readline prompt)
- (raw-input prompt))))
- (when (and use-readline-p
- input
- (not (zerop (length input))))
- (readline:add-history input))
- input))
-
-(defun mal-writeline (string)
- (when string
- (write-line string)))
-
-(defun repl ()
- (loop do (let ((line (mal-readline "user> ")))
- (if line
- (mal-writeline (rep line))
- (return))))
- (when use-readline-p
- (save-history)))
-
-(defun main ()
- (if (null common-lisp-user::*args*)
- ;; Do not start REPL inside Emacs
- (unless (member :swank *features*)
- (repl))
- (rep (format nil
- "(load-file \"~a\")"
- (car common-lisp-user::*args*)))))
-
-(main)
+++ /dev/null
-(require "dependencies")
-
-(defpackage :mal
- (:use :common-lisp
- :readline
- :types
- :env
- :reader
- :printer
- :core))
-
-(in-package :mal)
-
-(define-condition invalid-function (types:mal-runtime-exception)
- ((form :initarg :form :reader form)
- (context :initarg :context :reader context))
- (:report (lambda (condition stream)
- (format stream
- "Invalid function '~a' provided while ~a"
- (printer:pr-str (form condition))
- (if (string= (context condition) "apply")
- "applying"
- "defining macro")))))
-
-(defvar *repl-env* (env:create-mal-env))
-
-(dolist (binding core:ns)
- (env:set-env *repl-env*
- (car binding)
- (cdr binding)))
-
-(defvar mal-quote (make-mal-symbol "quote"))
-(defvar mal-quasiquote (make-mal-symbol "quasiquote"))
-(defvar mal-unquote (make-mal-symbol "unquote"))
-(defvar mal-splice-unquote (make-mal-symbol "splice-unquote"))
-(defvar mal-cons (make-mal-symbol "cons"))
-(defvar mal-concat (make-mal-symbol "concat"))
-(defvar mal-macroexpand (make-mal-symbol "macroexpand"))
-(defvar mal-def! (make-mal-symbol "def!"))
-(defvar mal-defmacro! (make-mal-symbol "defmacro!"))
-(defvar mal-let* (make-mal-symbol "let*"))
-(defvar mal-do (make-mal-symbol "do"))
-(defvar mal-if (make-mal-symbol "if"))
-(defvar mal-fn* (make-mal-symbol "fn*"))
-(defvar mal-try* (make-mal-symbol "try*"))
-(defvar mal-catch* (make-mal-symbol "catch*"))
-
-(env:set-env *repl-env*
- (types:make-mal-symbol "eval")
- (types:make-mal-builtin-fn (lambda (ast)
- (mal-eval ast *repl-env*))))
-
-(defun eval-sequence (sequence env)
- (map 'list
- (lambda (ast) (mal-eval ast env))
- (mal-data-value sequence)))
-
-(defun eval-hash-map (hash-map env)
- (let ((hash-map-value (mal-data-value hash-map))
- (new-hash-table (make-hash-table :test 'types:mal-value=)))
- (loop
- for key being the hash-keys of hash-map-value
- do (setf (gethash (mal-eval key env) new-hash-table)
- (mal-eval (gethash key hash-map-value) env)))
- (make-mal-hash-map new-hash-table)))
-
-(defun eval-ast (ast env)
- (switch-mal-type ast
- (types:symbol (env:get-env env ast))
- (types:list (eval-sequence ast env))
- (types:vector (make-mal-vector (apply 'vector (eval-sequence ast env))))
- (types:hash-map (eval-hash-map ast env))
- (types:any ast)))
-
-(defun is-pair (value)
- (and (or (mal-list-p value)
- (mal-vector-p value))
- (not (zerop (length (mal-data-value value))))))
-
-(defun quasiquote (ast)
- (if (not (is-pair ast))
- (types:make-mal-list (list mal-quote ast))
- (let ((forms (map 'list #'identity (mal-data-value ast))))
- (cond
- ((mal-value= mal-unquote (first forms))
- (second forms))
-
- ((and (is-pair (first forms))
- (mal-value= mal-splice-unquote
- (first (mal-data-value (first forms)))))
- (types:make-mal-list (list mal-concat
- (second (mal-data-value (first forms)))
- (quasiquote (make-mal-list (cdr forms))))))
-
- (t (types:make-mal-list (list mal-cons
- (quasiquote (first forms))
- (quasiquote (make-mal-list (cdr forms))))))))))
-
-(defun is-macro-call (ast env)
- (when (and (types:mal-list-p ast)
- (not (zerop (length (mal-data-value ast)))))
- (let* ((func-symbol (first (mal-data-value ast)))
- (func (when (types:mal-symbol-p func-symbol)
- (env:find-env env func-symbol))))
- (and func
- (types:mal-fn-p func)
- (cdr (assoc 'is-macro (types:mal-data-attrs func)))))))
-
-(defun mal-macroexpand (ast env)
- (loop
- while (is-macro-call ast env)
- do (let* ((forms (types:mal-data-value ast))
- (func (env:get-env env (first forms))))
- (setf ast (apply (mal-data-value func)
- (cdr forms)))))
- ast)
-
-(defun mal-eval (ast env)
- (loop
- do (setf ast (mal-macroexpand ast env))
- do (cond
- ((null ast) (return types:mal-nil))
- ((not (types:mal-list-p ast)) (return (eval-ast ast env)))
- ((zerop (length (mal-data-value ast))) (return ast))
- (t (let ((forms (mal-data-value ast)))
- (cond
- ((mal-value= mal-quote (first forms))
- (return (second forms)))
-
- ((mal-value= mal-quasiquote (first forms))
- (setf ast (quasiquote (second forms))))
-
- ((mal-value= mal-macroexpand (first forms))
- (return (mal-macroexpand (second forms) env)))
-
- ((mal-value= mal-def! (first forms))
- (return (env:set-env env (second forms) (mal-eval (third forms) env))))
-
- ((mal-value= mal-defmacro! (first forms))
- (let ((value (mal-eval (third forms) env)))
- (return (if (types:mal-fn-p value)
- (env:set-env env
- (second forms)
- (progn
- (setf (cdr (assoc 'is-macro (types:mal-data-attrs value))) t)
- value))
- (error 'invalid-function
- :form value
- :context "macro")))))
-
- ((mal-value= mal-let* (first forms))
- (let ((new-env (env:create-mal-env :parent env))
- ;; Convert a potential vector to a list
- (bindings (map 'list
- #'identity
- (mal-data-value (second forms)))))
-
- (mapcar (lambda (binding)
- (env:set-env new-env
- (car binding)
- (mal-eval (or (cdr binding)
- types:mal-nil)
- new-env)))
- (loop
- for (symbol value) on bindings
- by #'cddr
- collect (cons symbol value)))
- (setf ast (third forms)
- env new-env)))
-
- ((mal-value= mal-do (first forms))
- (mapc (lambda (form) (mal-eval form env))
- (butlast (cdr forms)))
- (setf ast (car (last forms))))
-
- ((mal-value= mal-if (first forms))
- (let ((predicate (mal-eval (second forms) env)))
- (setf ast (if (or (mal-value= predicate types:mal-nil)
- (mal-value= predicate types:mal-false))
- (fourth forms)
- (third forms)))))
-
- ((mal-value= mal-fn* (first forms))
- (return (let ((arglist (second forms))
- (body (third forms)))
- (types:make-mal-fn (lambda (&rest args)
- (mal-eval body (env:create-mal-env :parent env
- :binds (map 'list
- #'identity
- (mal-data-value arglist))
- :exprs args)))
- :attrs (list (cons 'params arglist)
- (cons 'ast body)
- (cons 'env env)
- (cons 'is-macro nil))))))
-
- ((mal-value= mal-try* (first forms))
- (handler-case
- (return (mal-eval (second forms) env))
- ((or types:mal-exception types:mal-error) (condition)
- (when (third forms)
- (let ((catch-forms (types:mal-data-value (third forms))))
- (when (mal-value= mal-catch*
- (first catch-forms))
- (return (mal-eval (third catch-forms)
- (env:create-mal-env :parent env
- :binds (list (second catch-forms))
- :exprs (list (if (or (typep condition 'types:mal-runtime-exception)
- (typep condition 'types:mal-error))
- (types:make-mal-string (format nil "~a" condition))
- (types::mal-exception-data condition)))))))))
- (error condition))))
-
- (t (let* ((evaluated-list (eval-ast ast env))
- (function (car evaluated-list)))
- ;; If first element is a mal function unwrap it
- (cond ((types:mal-fn-p function)
- (let* ((attrs (types:mal-data-attrs function)))
- (setf ast (cdr (assoc 'ast attrs))
- env (env:create-mal-env :parent (cdr (assoc 'env attrs))
- :binds (map 'list
- #'identity
- (mal-data-value (cdr (assoc 'params attrs))))
- :exprs (cdr evaluated-list)))))
- ((types:mal-builtin-fn-p function)
- (return (apply (mal-data-value function)
- (cdr evaluated-list))))
- (t (error 'invalid-function
- :form function
- :context "apply")))))))))))
-
-(defun mal-read (string)
- (reader:read-str string))
-
-(defun mal-print (expression)
- (printer:pr-str expression))
-
-(defun rep (string)
- (handler-case
- (mal-print (mal-eval (mal-read string)
- *repl-env*))
- (types:mal-error (condition)
- (format nil
- "Error: ~a"
- condition))
- (types:mal-runtime-exception (condition)
- (format nil
- "Exception: ~a"
- condition))
- (types:mal-user-exception (condition)
- (format nil
- "Exception: ~a"
- (pr-str (types::mal-exception-data condition))))
- (error (condition)
- (format nil
- "Internal error: ~a"
- condition))))
-
-(rep "(def! not (fn* (a) (if a false true)))")
-(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))")
-(rep "(def! *ARGV* (list))")
-(rep "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))")
-(rep "(def! *host-language* \"clisp\")")
-(rep "(def! *gensym-counter* (atom 0))")
-(rep "(def! gensym (fn* [] (symbol (str \"G__\" (swap! *gensym-counter* (fn* [x] (+ 1 x)))))))")
-(rep "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) (let* (condvar (gensym)) `(let* (~condvar ~(first xs)) (if ~condvar ~condvar (or ~@(rest xs)))))))))")
-(rep "(defmacro! defbuiltin! (fn* (arglist & forms) `(define-builtin '~arglist '~@forms)))")
-
-(env:set-env *repl-env*
- (types:make-mal-symbol "*ARGV*")
- (types:wrap-value (cdr common-lisp-user::*args*)
- :listp t))
-
-;; Readline setup
-;;; The test runner sets this environment variable, in which case we do
-;;; use readline since tests do not work with the readline interface
-(defvar use-readline-p (not (string= (ext:getenv "PERL_RL") "false")))
-
-(defvar *history-file* (namestring (merge-pathnames (user-homedir-pathname)
- ".mal-clisp-history")))
-
-(defun load-history ()
- (readline:read-history *history-file*))
-
-(defun save-history ()
- (readline:write-history *history-file*))
-
-;; Setup history
-(when use-readline-p
- (load-history))
-
-(defun raw-input (prompt)
- (format *standard-output* prompt)
- (force-output *standard-output*)
- (read-line *standard-input* nil))
-
-(defun mal-readline (prompt)
- (let ((input (if use-readline-p
- (readline:readline prompt)
- (raw-input prompt))))
- (when (and use-readline-p
- input
- (not (zerop (length input))))
- (readline:add-history input))
- input))
-
-(defun mal-writeline (string)
- (when string
- (write-line string)))
-
-(defun repl ()
- (rep "(println (str \"Mal [\" *host-language* \"]\"))");
- (loop do (let ((line (mal-readline "user> ")))
- (if line
- (mal-writeline (rep line))
- (return))))
- (when use-readline-p
- (save-history)))
-
-(defun main ()
- (if (null common-lisp-user::*args*)
- ;; Do not start REPL inside Emacs
- (unless (member :swank *features*)
- (repl))
- (rep (format nil
- "(load-file \"~a\")"
- (car common-lisp-user::*args*)))))
-
-(main)
+++ /dev/null
-;; Testing clisp interop
-
-(clisp-eval "42")
-;=>42
-
-(clisp-eval "(+ 1 1)")
-;=>2
-
-(clisp-eval "(setq foo 1 bar 2 baz 3)")
-
-(clisp-eval "(list foo bar baz)")
-;=>(1 2 3)
-
-(clisp-eval "7")
-;=>7
-
-;;
-;; Testing boolean flag
-(clisp-eval "(= 123 123)" true)
-;=>true
-
-(clisp-eval "(= 123 456)")
-;=>nil
-
-(clisp-eval "(= 123 456)" true)
-;=>false
-
-;;
-;; Testing list flag
-(clisp-eval "(last nil)" false true)
-;=>()
-
-(clisp-eval "nil" false true)
-;=>()
-
-(clisp-eval "nil")
-;=>nil
-
-;;
-;; Testing creation of Common Lisp Objects
-(clisp-eval "#(1 2)")
-;=>[1 2]
-
-;;; Not testing with elements since order in hashtable cannot be guaranteed
-(clisp-eval "(make-hash-table)")
-;=>{}
-
-(clisp-eval "(defun redundant-identity (x) x)"))
-;=>REDUNDANT-IDENTITY
-
-(clisp-eval "(redundant-identity 2)"))
-;=>2
-
-(clisp-eval "(defun range (max &key (min 0) (step 1)) (loop for n from min below max by step collect n))")
-;=>RANGE
-
-(clisp-eval "(range 10 :min 0 :step 1)")
-;=>(0 1 2 3 4 5 6 7 8 9)
-
-(clisp-eval "(mapcar #'1+ (range 10 :min 0 :step 1))")
-;=>(1 2 3 4 5 6 7 8 9 10)
-
-;;
-;; Testing defbuiltin!
-(def! make-native-hash-map (defbuiltin! (&REST args) (MAKE-HASH-TABLE :initial-contents (LOOP FOR (KEY VALUE) ON args BY (FUNCTION CDDR) COLLECT (CONS KEY VALUE)))))
-;=>#<builtin function>
-
-(make-native-hash-map 1 2)
-;=>{1 2}
-
-(def! native-range (defbuiltin! (max &KEY (MIN 0) (STEP 1)) (LOOP FOR n FROM MIN BELOW max BY STEP COLLECT n)))
-;=>#<builtin function>
-
-(native-range 10 :MIN 2 :STEP 2)
-;=>(2 4 6 8)
\ No newline at end of file
+++ /dev/null
-;; Dummy package where MAL variables are interned
-(defpackage :mal-user
- (:use :common-lisp))
-
-(defpackage :types
- (:use :common-lisp)
- (:export :mal-value=
-
- ;; Accessors
- :mal-data-value
- :mal-data-type
- :mal-data-meta
- :mal-data-attrs
-
- ;; Mal values
- :number
- :make-mal-number
- :mal-number-p
-
- :boolean
- :mal-boolean-p
-
- :nil
- :mal-nil-p
-
- :string
- :make-mal-string
- :mal-string-p
-
- :symbol
- :make-mal-symbol
- :mal-symbol-p
-
- :keyword
- :make-mal-keyword
- :mal-keyword-p
-
- :list
- :make-mal-list
- :mal-list-p
-
- :vector
- :make-mal-vector
- :mal-vector-p
-
- :hash-map
- :make-mal-hash-map
- :mal-hash-map-p
-
- :atom
- :make-mal-atom
- :mal-atom-p
-
- :fn
- :make-mal-fn
- :mal-fn-p
-
- :builtin-fn
- :make-mal-builtin-fn
- :mal-builtin-fn-p
-
- :any
-
- ;; Singleton values
- :mal-nil
- :mal-true
- :mal-false
-
- :mal-exception
-
- ;; User exceptions
- :mal-user-exception
-
- ;; Exceptions raised by the runtime itself
- :mal-runtime-exception
-
- ;; Error
- :mal-error
-
- ;; Helpers
- :wrap-value
- :unwrap-value
- :apply-unwrapped-values
- :apply-unwrapped-values-prefer-bool
- :switch-mal-type))
-
-(in-package :types)
-
-(define-condition mal-error (error)
- nil)
-
-(define-condition mal-exception (error)
- nil)
-
-(define-condition mal-runtime-exception (mal-exception)
- nil)
-
-(define-condition mal-user-exception (mal-exception)
- ((data :accessor mal-exception-data :initarg :data)))
-
-(defstruct mal-data
- (type nil :read-only t)
- (value nil)
- meta
- attrs)
-
-(defmacro define-mal-type (type)
- ;; Create a class for given type and a convenience constructor and also export
- ;; them
- (let ((constructor (intern (string-upcase (concatenate 'string
- "make-mal-"
- (symbol-name type)))))
- (predicate (intern (string-upcase (concatenate 'string
- "mal-"
- (symbol-name type)
- "-p")))))
- `(progn (defun ,constructor (value &key meta attrs)
- (make-mal-data :type ',type
- :value value
- :meta meta
- :attrs attrs))
-
- (defun ,predicate (value)
- (when (typep value 'mal-data)
- (equal (mal-data-type value) ',type))))))
-
-(define-mal-type number)
-(define-mal-type symbol)
-(define-mal-type keyword)
-(define-mal-type string)
-;; TODO true, false and nil should ideally be singleton
-(define-mal-type boolean)
-(define-mal-type nil)
-
-(define-mal-type list)
-(define-mal-type vector)
-(define-mal-type hash-map)
-
-(define-mal-type atom)
-
-(define-mal-type fn)
-(define-mal-type builtin-fn)
-
-(defvar mal-nil (make-mal-nil nil))
-(defvar mal-true (make-mal-boolean t))
-(defvar mal-false (make-mal-boolean nil))
-
-;; Generic type
-(defvar any)
-
-(defmacro switch-mal-type (ast &body forms)
- `(let ((type (types:mal-data-type ,ast)))
- (cond
- ,@(mapcar (lambda (form)
- (list (if (or (equal (car form) t)
- (equal (car form) 'any))
- t
- (list 'equal (list 'quote (car form)) 'type))
- (cadr form)))
- forms))))
-
-(defun mal-symbol= (value1 value2)
- (string= (mal-data-value value1)
- (mal-data-value value2)))
-
-(defun mal-sequence= (value1 value2)
- (let ((sequence1 (map 'list #'identity (mal-data-value value1)))
- (sequence2 (map 'list #'identity (mal-data-value value2))))
- (when (= (length sequence1) (length sequence2))
- (every #'identity
- (loop
- for x in sequence1
- for y in sequence2
- collect (mal-value= x y))))))
-
-(defun mal-hash-map= (value1 value2)
- (let ((map1 (mal-data-value value1))
- (map2 (mal-data-value value2)))
- (when (= (hash-table-count map1) (hash-table-count map2))
- (every #'identity
- (loop
- for key being the hash-keys of map1
- collect (mal-value= (gethash key map1)
- (gethash key map2)))))))
-
-(defun mal-value= (value1 value2)
- (when (and (typep value1 'mal-data)
- (typep value2 'mal-data))
- (if (equal (mal-data-type value1) (mal-data-type value2))
- (switch-mal-type value1
- (list (mal-sequence= value1 value2))
- (vector (mal-sequence= value1 value2))
- (hash-map (mal-hash-map= value1 value2))
- (any (equal (mal-data-value value1) (mal-data-value value2))))
- (when (or (and (mal-list-p value1) (mal-vector-p value2))
- (and (mal-list-p value2) (mal-vector-p value1)))
- (mal-sequence= value1 value2)))))
-
-(defun hash-mal-value (value)
- (sxhash (mal-data-value value)))
-
-(ext:define-hash-table-test mal-value= mal-value= hash-mal-value)
-
-(defun wrap-hash-value (value)
- (let ((new-hash-table (make-hash-table :test 'mal-value=)))
- (loop
- for key being the hash-keys of value
- do (setf (gethash (wrap-value key) new-hash-table)
- (wrap-value (gethash key value))))
- new-hash-table))
-
-(defun wrap-value (value &key booleanp listp)
- "Convert a Common Lisp value to MAL value"
- (typecase value
- (number (make-mal-number value))
- ;; This needs to before symbol since nil is a symbol
- (null (cond
- (booleanp mal-false)
- (listp (make-mal-list nil))
- (t mal-nil)))
- ;; This needs to before symbol since t, nil are symbols
- (boolean (if value mal-true mal-false))
- (symbol (make-mal-symbol (symbol-name value)))
- (keyword (make-mal-keyword value))
- (string (make-mal-string value))
- (list (make-mal-list (map 'list #'wrap-value value)))
- (vector (make-mal-vector (map 'vector #'wrap-value value)))
- (hash-table (make-mal-hash-map (wrap-hash-value value)))
- (null mal-nil)))
-
-(defun unwrap-value (value)
- "Convert a MAL value to native Common Lisp value"
- (switch-mal-type value
- (list (mapcar #'unwrap-value (mal-data-value value)))
- (vector (map 'vector #'unwrap-value (mal-data-value value)))
- (hash-map (let ((hash-table (make-hash-table))
- (hash-map-value (mal-data-value value)))
- (loop
- for key being the hash-keys of hash-map-value
- do (setf (gethash (mal-data-value key) hash-table)
- (mal-data-value (gethash key hash-map-value))))
- hash-table))
- ;; Unfortunately below means even symbols that user indented to use
- ;; from the common lisp are interned in lowercase thus runtime
- ;; will not find them as such users need to explicitly upcase the
- ;; symbols from common lisp
- (symbol (intern (mal-data-value value) :mal-user))
- ;; In case of a keyword strip the first colon, and intern the symbol in
- ;; keyword package
- (keyword (intern (string-upcase (subseq (mal-data-value value) 1))
- :keyword))
- (any (mal-data-value value))))
-
-(defun apply-unwrapped-values (op &rest values)
- (wrap-value (apply op (mapcar #'unwrap-value values))))
-
-(defun apply-unwrapped-values-prefer-bool (op &rest values)
- (wrap-value (apply op (mapcar #'unwrap-value values)) :booleanp t))
+++ /dev/null
-(defpackage :utils
- (:use :common-lisp)
- (:export :replace-all))
-
-(in-package :utils)
-
-(defun replace-all (string part replacement &key (test #'char=))
- "Returns a new string in which all the occurences of the part
-is replaced with replacement."
- (with-output-to-string (out)
- (loop with part-length = (length part)
- for old-pos = 0 then (+ pos part-length)
- for pos = (search part string
- :start2 old-pos
- :test test)
- do (write-string string out
- :start old-pos
- :end (or pos (length string)))
- when pos do (write-string replacement out)
- while pos)))
HCoop / jackhill / mal.git / commitdiff