mirror of
https://github.com/kanaka/mal.git
synced 2024-09-20 10:07:45 +03:00
105 lines
4.0 KiB
Common Lisp
105 lines
4.0 KiB
Common Lisp
(defpackage :env
|
|
(:use :common-lisp :types)
|
|
(:export :undefined-symbol
|
|
:mal-environment
|
|
: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)))))
|
|
|
|
(defclass mal-environment ()
|
|
((bindings :initarg :bindings
|
|
:accessor mal-env-bindings
|
|
:initform (make-hash-table :test 'types:mal-value=))
|
|
(parent :initarg :parent
|
|
:accessor mal-env-parent
|
|
:initform nil)))
|
|
|
|
(defgeneric find-env (mal-environment symbol)
|
|
(:documentation "Find value of a symbol in given environment, return nil if not binding is found"))
|
|
|
|
(defgeneric get-env (mal-environment symbol)
|
|
(:documentation "Get value of a symbol in given environment, raises undefined-symbol error if lookup fails"))
|
|
|
|
(defgeneric set-env (mal-environment symbol value)
|
|
(:documentation "Set the value for a symbol in given environment"))
|
|
|
|
(defmethod find-env ((env mal-environment) symbol)
|
|
(let ((value (gethash symbol (mal-env-bindings env)))
|
|
(parent (mal-env-parent env)))
|
|
(cond
|
|
(value value)
|
|
(parent (find-env parent symbol))
|
|
(t nil))))
|
|
|
|
(defmethod get-env ((env mal-environment) symbol)
|
|
(let ((value (find-env env symbol)))
|
|
(if value
|
|
value
|
|
(error 'undefined-symbol
|
|
:symbol (format nil "~a" (types:mal-data-value symbol))))))
|
|
|
|
(defmethod set-env ((env mal-environment) symbol value)
|
|
(setf (gethash symbol (mal-env-bindings env)) value))
|
|
|
|
(defmethod initialize-instance :after ((env mal-environment)
|
|
&key (bindings nil)
|
|
(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)))
|
|
(dolist (arg-param arg-params)
|
|
(set-env env
|
|
(car arg-param)
|
|
(cdr arg-param))))))
|