mirror of
https://github.com/kanaka/mal.git
synced 2024-09-20 01:57:09 +03:00
105 lines
2.9 KiB
EmacsLisp
105 lines
2.9 KiB
EmacsLisp
;;; general accessors
|
|
|
|
(defun mal-type (mal-object)
|
|
(aref mal-object 0))
|
|
|
|
(defun mal-value (mal-object)
|
|
(aref mal-object 1))
|
|
|
|
(defun mal-meta (mal-object)
|
|
(aref mal-object 2))
|
|
|
|
;;; objects
|
|
|
|
(defmacro mal-object (name)
|
|
(let ((constructor (intern (format "mal-%s" name)))
|
|
(predicate (intern (format "mal-%s-p" name))))
|
|
`(progn
|
|
(defun ,constructor (&optional value meta)
|
|
(vector ',name value meta))
|
|
(defun ,predicate (arg)
|
|
(and (arrayp arg) (eq (aref arg 0) ',name))))))
|
|
|
|
(mal-object nil)
|
|
(mal-object true)
|
|
(mal-object false)
|
|
|
|
(defvar mal-nil (mal-nil))
|
|
(defvar mal-true (mal-true 'true))
|
|
(defvar mal-false (mal-false 'false))
|
|
|
|
(mal-object number)
|
|
(mal-object string)
|
|
(mal-object symbol)
|
|
(mal-object keyword)
|
|
|
|
(mal-object list)
|
|
(mal-object vector)
|
|
(mal-object map)
|
|
|
|
(mal-object env)
|
|
(mal-object atom)
|
|
|
|
(mal-object fn)
|
|
(mal-object func)
|
|
|
|
;;; regex
|
|
|
|
(defvar token-re
|
|
(rx (* (any white ?,)) ;; leading whitespace
|
|
(group
|
|
(or
|
|
"~@" ;; special 2-char token
|
|
(any "[]{}()'`~^@") ;; special 1-char tokens
|
|
(and ?\" (* (or (and ?\\ anything)
|
|
(not (any "\\\""))))
|
|
?\") ;; string with escapes
|
|
(and ?\; (* not-newline)) ;; comment
|
|
(* (not (any white "[]{}()'\"`,;"))) ;; catch-all
|
|
))))
|
|
|
|
(defvar whitespace-re
|
|
(rx bos (* (any white ?,)) eos))
|
|
|
|
(defvar comment-re
|
|
(rx bos ?\; (* anything)))
|
|
|
|
(defvar sequence-end-re
|
|
(rx bos (any ")]}") eos))
|
|
|
|
(defvar number-re
|
|
(rx bos (? (any "+-")) (+ (char digit)) eos))
|
|
|
|
(defvar string-re
|
|
(rx bos ?\" (* (or (and ?\\ anything)
|
|
(not (any "\\\""))))
|
|
?\" eos))
|
|
|
|
;;; errors
|
|
|
|
(when (not (fboundp 'define-error))
|
|
(defun define-error (name message &optional parent)
|
|
"Define NAME as a new error signal.
|
|
MESSAGE is a string that will be output to the echo area if such an error
|
|
is signaled without being caught by a `condition-case'.
|
|
PARENT is either a signal or a list of signals from which it inherits.
|
|
Defaults to `error'."
|
|
(unless parent (setq parent 'error))
|
|
(let ((conditions
|
|
(if (consp parent)
|
|
(apply #'nconc
|
|
(mapcar (lambda (parent)
|
|
(cons parent
|
|
(or (get parent 'error-conditions)
|
|
(error "Unknown signal `%s'" parent))))
|
|
parent))
|
|
(cons parent (get parent 'error-conditions)))))
|
|
(put name 'error-conditions
|
|
(delete-dups (copy-sequence (cons name conditions))))
|
|
(when message (put name 'error-message message)))))
|
|
|
|
(define-error 'mal "MAL error")
|
|
(define-error 'unterminated-sequence "Unterminated token sequence" 'mal)
|
|
(define-error 'end-of-token-stream "End of token stream" 'mal)
|
|
(define-error 'mal-custom "Custom error" 'mal)
|