--- /dev/null
+(defpackage :printer
+ (:use :common-lisp :types :genhash)
+ (:import-from :cl-ppcre
+ :regex-replace)
+ (:import-from :utils
+ :replace-all)
+ (: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 (repr)
+ (genhash:hashmap (lambda (key value)
+ (push (format nil
+ "~a ~a"
+ (pr-str key print-readably)
+ (pr-str value print-readably))
+ repr))
+ hash-map-value)
+ repr))
+ "}")))
+
+(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 (format nil "~a" (types:mal-data-value ast)))
+ (types:keyword (format nil "~a" (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)))))))
--- /dev/null
+(defpackage :reader
+ (:use :common-lisp :types :genhash)
+ (:import-from :cl-ppcre
+ :create-scanner
+ :do-matches-as-strings
+ :scan)
+ (:import-from :utils
+ :replace-all)
+ (:export :read-str
+ :eof
+ :unexpected-token))
+
+(in-package :reader)
+
+;; Possible errors that can be raised while reading a string
+(define-condition unexpected-token (error)
+ ((expected :initarg :expected :reader expected-token)
+ (actual :initarg :actual :reader actual-token))
+ (:report (lambda (condition stream)
+ (format stream
+ "Unexpected token (~a) encountered while reading, expected ~a"
+ (actual-token condition)
+ (expected-token condition))))
+ (:documentation "Error raised when an unexpected token is encountered while reading."))
+
+(define-condition eof (error)
+ ((context :initarg :context :reader context))
+ (:report (lambda (condition stream)
+ (format stream
+ "EOF encountered while reading ~a"
+ (context condition))))
+ (:documentation "Error raised when EOF is encountered while reading."))
+
+(defvar *tokenizer-re* (create-scanner "[\\s,]*(~@|[\\[\\]{}()'`~^@]|\"(?:\\\\.|[^\\\\\"])*\"?|;.*|[^\\s\\[\\]{}('\"`,;)]*)")
+ "Regular expression to tokenize Lisp code")
+
+(defvar *number-re* (create-scanner "^(-|\\+)?[\\d]+$")
+ "Regular expression to match a number")
+
+(defvar *string-re* (create-scanner "^\"(?:\\\\.|[^\\\\\"])*\"$")
+ "Regular expression to match a string")
+
+(defvar *whitespace-chars*
+ '(#\Space #\Newline #\Backspace #\Tab
+ #\Linefeed #\Page #\Return #\Rubout #\,)
+ "Characters to treat as whitespace, these are trimmed in `tokenize'")
+
+(defun tokenize (string)
+ "Tokenize given string.
+
+This function extracts all tokens from the string using *tokenizer-re*
+comments are ignored.
+
+Implementation notes: The regex scan generates some empty tokens, not really
+sure why."
+ (let (tokens)
+ (do-matches-as-strings (match *tokenizer-re* string)
+ (let ((token (string-trim *whitespace-chars* match)))
+ (unless (or (zerop (length token))
+ (char= (char token 0) #\;))
+ (push token tokens))))
+ (nreverse tokens)))
+
+;; Reader
+(defstruct (token-reader)
+ (tokens nil))
+
+(defun peek (reader)
+ "Returns the next token in the reader without advancing the token stream."
+ (car (token-reader-tokens reader)))
+
+(defun next (reader)
+ "Returns the next token and advances the token stream."
+ (pop (token-reader-tokens reader)))
+
+(defun consume (reader &optional (token nil token-provided-p))
+ "Consume the next token and advance the token stream.
+
+If the optional argument token is provided the token stream is advanced only
+if token being consumes matches it otherwise and unexpected token error is
+raised"
+ (let ((actual-token (pop (token-reader-tokens reader))))
+ (when (and token-provided-p
+ (not (equal actual-token token)))
+ (error 'unexpected-token
+ :expected token
+ :actual actual-token)))
+ reader)
+
+(defun parse-string (token)
+ (if (and (> (length token) 1)
+ (scan *string-re* token))
+ (read-from-string (utils:replace-all token
+ "\\n"
+ "
+"))
+ (error 'eof
+ :context "string")))
+
+(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
+ (hash-map (types:make-mal-value-hash-table)))
+ (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)
+ ;; Construct the hash table
+ (dolist (key-value (nreverse forms))
+ (setf (genhash:hashref (car key-value) hash-map) (cdr key-value)))
+ hash-map))
+
+(defun read-atom (reader)
+ (let ((token (next reader)))
+ (cond
+ ((string= token "false")
+ (make-mal-boolean nil))
+ ((string= token "true")
+ (make-mal-boolean t))
+ ((string= token "nil")
+ (make-mal-nil nil))
+ ((char= (char token 0) #\")
+ (make-mal-string (parse-string token)))
+ ((char= (char token 0) #\:)
+ (make-mal-keyword token))
+ ((scan *number-re* token)
+ (make-mal-number (read-from-string token)))
+ (t (make-mal-symbol token)))))
+
+(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-str (string)
+ (read-form (make-token-reader :tokens (tokenize string))))
--- /dev/null
+(defpackage :mal
+ (:use :common-lisp
+ :reader
+ :printer
+ :utils)
+ (:export :main))
+
+(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)
+ (make-hash-table :test #'equal)))
+ (reader:eof (condition)
+ (format nil
+ "~a"
+ condition))))
+
+(defvar *use-readline-p* nil)
+
+(defun raw-input (prompt)
+ (format *standard-output* prompt)
+ (force-output *standard-output*)
+ (read-line *standard-input* nil))
+
+(defun mal-readline (prompt)
+ (if *use-readline-p*
+ (cl-readline:readline :prompt prompt
+ :add-history t
+ :novelty-check (lambda (old new)
+ (not (string= old new))))
+ (raw-input prompt)))
+
+(defun mal-writeline (string)
+ (when string
+ (write-line string)
+ (force-output *standard-output*)))
+
+(defun main (&optional (argv nil argv-provided-p))
+ (declare (ignorable argv argv-provided-p))
+ (setf *use-readline-p* (not (or (string= (uiop:getenv "PERL_RL") "false")
+ (string= (uiop:getenv "TERM") "dumb"))))
+ (loop do (let ((line (mal-readline "user> ")))
+ (if line (mal-writeline (rep line)) (return)))))
--- /dev/null
+(defpackage :types
+ (:use :common-lisp :genhash)
+ (:export ;; Accessors
+ :mal-data-value
+ :mal-data-type
+ :mal-data-meta
+ :mal-data-attrs
+ ;; Mal values
+ :number
+ :make-mal-number
+ :mal-number-p
+
+ :boolean
+ :make-mal-boolean
+ :mal-boolean-p
+
+ :nil
+ :make-mal-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
+
+ :any
+
+ :switch-mal-type
+
+ ;; Hashing mal values
+ :make-mal-value-hash-table))
+
+(in-package :types)
+
+(defstruct mal-data
+ (value nil :read-only t)
+ (type nil :read-only t)
+ meta
+ attrs)
+
+;; Create a constructor and predicate for given type
+(defmacro define-mal-type (type)
+ (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)
+ (eq (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)
+
+;; Generic type
+(defvar any)
+
+(defun mal-data-value= (value1 value2)
+ (equal (mal-data-value value1)
+ (mal-data-value value2)))
+
+(defun make-mal-value-hash-table ()
+ (unless (gethash 'mal-data-value-hash genhash::*hash-test-designator-map*)
+ (genhash:register-test-designator 'mal-data-value-hash
+ #'sxhash
+ #'mal-data-value=))
+ (genhash:make-generic-hash-table :test 'mal-data-value-hash))
+
+(defmacro switch-mal-type (ast &body forms)
+ `(let ((type (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))))
HCoop / jackhill / mal.git / commitdiff