├── .gitignore ├── COPYRIGHT ├── README ├── microlisp.asd └── src └── xi ├── classes.lisp ├── eval.lisp ├── objects.lisp ├── package.lisp └── symbols.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *.tmp 3 | *.fasl 4 | *.fas 5 | *.wx32fsl 6 | *.wx64fsl 7 | *.diff 8 | *.patch 9 | *.swp 10 | -------------------------------------------------------------------------------- /COPYRIGHT: -------------------------------------------------------------------------------- 1 | Copyright (C) 2011, Dmitry Ignatiev 2 | 3 | Permission is hereby granted, free of charge, to any person 4 | obtaining a copy of this software and associated documentation 5 | files (the "Software"), to deal in the Software without 6 | restriction, including without limitation the rights to use, copy, 7 | modify, merge, publish, distribute, sublicense, and/or sell copies 8 | of the Software, and to permit persons to whom the Software is 9 | furnished to do so, subject to the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 18 | HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 19 | WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 | DEALINGS IN THE SOFTWARE. 22 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | Codename: Microlisp 2 | 3 | Features: lisp-1, all instances are funcallable, sane namespace system 4 | and so on. NO continuations, but CL-like control structures. 5 | 6 | `XI'(src/xi) is a work-in-progress cross-interpreter, written in Common Lisp. 7 | -------------------------------------------------------------------------------- /microlisp.asd: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 | 3 | ;;; Copyright (C) 2010-2011, Dmitry Ignatiev 4 | 5 | ;;; Permission is hereby granted, free of charge, to any person 6 | ;;; obtaining a copy of this software and associated documentation 7 | ;;; files (the "Software"), to deal in the Software without 8 | ;;; restriction, including without limitation the rights to use, copy, 9 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 10 | ;;; of the Software, and to permit persons to whom the Software is 11 | ;;; furnished to do so, subject to the following conditions: 12 | 13 | ;;; The above copyright notice and this permission notice shall be 14 | ;;; included in all copies or substantial portions of the Software. 15 | 16 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 20 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 21 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 23 | ;;; DEALINGS IN THE SOFTWARE. 24 | 25 | (defsystem #:microlisp 26 | :depends-on () 27 | :pathname #P"src/xi/" 28 | :serial t 29 | :components ((:file "package") 30 | (:file "objects") 31 | (:file "symbols") 32 | (:file "eval") 33 | )) 34 | 35 | ;;; vim: ft=lisp et 36 | -------------------------------------------------------------------------------- /src/xi/classes.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:microlisp) 2 | 3 | (enable-xi-syntax) 4 | 5 | (defmacro defcinst (name) 6 | `(defconstant ,name (if (boundp ',name) 7 | (symbol-value ',name) 8 | (alloc-inst)))) 9 | 10 | (defcinst +standard-class+) 11 | 12 | (disable-xi-syntax) -------------------------------------------------------------------------------- /src/xi/eval.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:microlisp) 2 | 3 | (enable-xi-syntax) 4 | 5 | (define-condition lisp-runtime-error (error) 6 | ((message :initarg :message 7 | :reader lisp-runtime-error-message)) 8 | (:default-initargs :message nil) 9 | (:report (lambda (condition stream) 10 | (format stream "Lisp runtime error~:[.~; ~:*~a~]" 11 | (lisp-runtime-error-message condition)) 12 | condition))) 13 | 14 | (defun lisp-runtime-error (message &rest args) 15 | (error 'lisp-runtime-error 16 | :message (apply #'format nil message args))) 17 | 18 | (defvar *dynamic-vars* '()) 19 | (defvar *catch-tags* '()) 20 | (defvar +global-var-info+ (make-hash-table :test #'eq)) 21 | 22 | ;; We really must implement this as a target lisp class. 23 | (defstruct (env (:constructor %make-env)) 24 | vars 25 | tags 26 | blocks) 27 | 28 | (defun make-env (&key parent vars tags blocks) 29 | (if (null parent) 30 | (%make-env :vars vars 31 | :tags tags 32 | :blocks blocks) 33 | (%make-env :vars (append vars (env-vars parent)) 34 | :tags (append tags (env-tags parent)) 35 | :blocks (append blocks (env-blocks parent))))) 36 | 37 | (defun env-var (env symbol) 38 | (find symbol (env-vars env) 39 | :key #'car :test #'eq)) 40 | 41 | (defun env-tag (env symbol) 42 | (find symbol (env-tags env) 43 | :key #'car :test #'eq)) 44 | 45 | (defun env-block (env symbol) 46 | (find symbol (env-blocks env) 47 | :key #'car :test #'eq)) 48 | 49 | (defun error-unbound-variable (symbol) 50 | (eval-call (sym-value [signal-error]) 51 | (list (sym-value [unbound-variable]) symbol))) 52 | 53 | (defun error-constant-modification (symbol) 54 | (eval-call (sym-value [signal-error]) 55 | (list (sym-value [constant-modification]) symbol))) 56 | 57 | (defun error-arg-count (args) 58 | (eval-call (sym-value [signal-error]) 59 | (list (sym-value [invalid-argument-count]) args))) 60 | 61 | (defun error-not-symbol (datum) 62 | (eval-call (sym-value [signal-error]) 63 | (list (sym-value [class-error]) 64 | datum 65 | (sym-value [symbol])))) 66 | 67 | (defun error-not-list (datum) 68 | (eval-call (sym-value [signal-error]) 69 | (list (sym-value [class-error]) 70 | datum 71 | (sym-value [list])))) 72 | 73 | (defun error-not-function (datum) 74 | (eval-call (sym-value [signal-error]) 75 | (list (sym-value [class-error]) 76 | datum 77 | (sym-value [function])))) 78 | 79 | (defun error-not-callable (datum) 80 | (eval-call (sym-value [signal-error]) 81 | (list (sym-value [instance-not-callable]) 82 | datum))) 83 | 84 | (defun error-not-class-of (datum class) 85 | (eval-call (sym-value [signal-error]) 86 | (list (sym-value [class-error]) 87 | datum 88 | class))) 89 | 90 | (defun error-duplicate-doc (doc) 91 | (eval-call (sym-value [signal-error]) 92 | (list (sym-value [duplicate-docstring]) 93 | doc))) 94 | 95 | (defun error-invalid-decl (decl) 96 | (eval-call (sym-value [signal-error]) 97 | (list (sym-value [invalid-declaration]) 98 | decl))) 99 | 100 | (defun error-invalid-decl-context (decl) 101 | (eval-call (sym-value [signal-error]) 102 | (list (sym-value [invalid-declaration-context]) 103 | decl))) 104 | 105 | (defun error-dup-vardecl (decl) 106 | (eval-call (sym-value [signal-error]) 107 | (list (sym-value [duplicate-variable-declaration]) 108 | decl))) 109 | 110 | (defun get-symbol-value (symbol) 111 | (let ((dynvar (find symbol *dynamic-vars* 112 | :key #'car))) 113 | (if (not dynvar) 114 | (case (gethash symbol +global-var-info+) 115 | ((:static :constant :macro) (sym-value symbol)) 116 | (T (if (eq (sym-value symbol) :unbound) 117 | (error-unbound-variable symbol) 118 | (sym-value symbol)))) 119 | (if (eq :unbound (cdr dynvar)) 120 | (error-unbound-variable symbol) 121 | (cdr dynvar))))) 122 | 123 | (defun set-symbol-value (new-value symbol) 124 | (let ((dynvar (find symbol *dynamic-vars* 125 | :key #'car))) 126 | (if (not dynvar) 127 | (case (gethash symbol +global-var-info+) 128 | (:constant (error-constant-modification symbol)) 129 | (T (setf (sym-value symbol) new-value))) 130 | (setf (cdr dynvar) new-value)))) 131 | 132 | (defun eval-ref (symbol env) 133 | (let ((var (env-var env symbol))) 134 | (if (null var) 135 | (case (gethash symbol +global-var-info+) 136 | (:dynamic (get-symbol-value symbol)) 137 | (:static (sym-value symbol)) 138 | (T (if (eq :unbound (sym-value symbol)) 139 | (error-unbound-variable symbol) 140 | (sym-value symbol)))) 141 | (ecase (second var) 142 | (:dynamic (get-symbol-value symbol)) 143 | (:static (cddr var)))))) 144 | 145 | (defun %eval-setq (symbol value env) 146 | (let ((var (env-var env symbol))) 147 | (if (null var) 148 | (case (gethash symbol +global-var-info+) 149 | (:dynamic (set-symbol-value symbol (eval-form value env))) 150 | (:constant (error-constant-modification symbol)) 151 | (:macro (eval-form `([setf] ,symbol ,value) env)) 152 | (T (setf (sym-value symbol) (eval-form value env)))) 153 | (ecase (second var) 154 | (:dynamic (set-symbol-value symbol (eval-form value env))) 155 | (:static (setf (cddr var) (eval-form value env))) 156 | (:constant (error-constant-modification symbol)) 157 | (:macro (eval-form `([setf] ,symbol ,value) env)))))) 158 | 159 | (defun expand (form env) 160 | (cond 161 | ((symbol-object-p form) 162 | (let ((var (env-var form))) 163 | (if (null var) 164 | (case (gethash form +global-var-info+) 165 | (:macro (expand (sym-value form))) 166 | (:constant (sym-value form)) 167 | (t form)) 168 | (ecase (second var) 169 | (:macro (expand (cddr var))) 170 | (:constant (cddr var)) 171 | (t form))))) 172 | ((consp form) 173 | (if (symbol-object-p (car form)) 174 | (let ((var (env-var (car form)))) 175 | (if (null var) 176 | (case (gethash (car form) +global-var-info+) 177 | (:macro (expand (eval-call 178 | (sym-value (car form)) 179 | (list form env)))) 180 | (T form)) 181 | (ecase (second var) 182 | (:macro (expand (eval-call 183 | (cddr var) 184 | (list form env)))) 185 | (T form)))) 186 | form)) 187 | (T form))) 188 | 189 | (defun parse-body (body &key allow-doc allow-locals allow-macros) 190 | (multiple-value-bind 191 | (doc decls forms) 192 | (loop :with doc = nil 193 | :with decls = '() 194 | :for form :on body :do 195 | (cond ((and allow-doc (stringp (car form))) 196 | (if doc 197 | (error-duplicate-doc (car form)) 198 | (setf doc (car form)))) 199 | ((and (consp form) (eq [declare] (caar form))) 200 | (setf decls (append decls (cdar form)))) 201 | (T (return (values doc decls form)))) 202 | :finally (return (values doc decls nil))) 203 | (let (statics dynamics constants macros names) 204 | (dolist (d decls) 205 | (if (consp d) 206 | (macrolet ((foo (vtype) 207 | (let ((v (gensym)) 208 | (r (gensym))) 209 | `(loop :for (,v . ,r) :on (cdr d) 210 | :if (null ,r) :do (return) 211 | :else :if (atom ,r) 212 | :do (error-not-list d) 213 | :else :if (find ,v names) 214 | :do (error-dup-vardecl d) 215 | :else :do 216 | (push ,v names) 217 | (push ,v ,vtype))))) 218 | (case (car d) 219 | ([dynamic] (foo dynamics)) 220 | ([static] (if allow-locals 221 | (foo statics) 222 | (error-invalid-decl-context d))) 223 | ([constant] (if allow-macros 224 | (foo constants) 225 | (error-invalid-decl-context d))) 226 | ([macro] (if allow-macros 227 | (foo macros) 228 | (error-invalid-decl-context d))))) 229 | (error-invalid-decl d))) 230 | (values forms doc statics dynamics constants macros)))) 231 | 232 | ;; Microlisp set of special operators is very similiar to that 233 | ;; of Common Lisp, so in case of XI we reuse existing CL control structures 234 | ;; and specifically, an implementation of NLX an dynamic environments. 235 | ;; Upcoming Microlisp runtime and compiler should implement all 236 | ;; this stuff from scratch. 237 | 238 | (defun eval-quote (form env) 239 | (declare (ignore env)) 240 | (if (= 2 (length form)) 241 | (second form) 242 | (error-arg-count (cdr form)))) 243 | 244 | (defun eval-setq (form env) 245 | (let ((pairs (rest form))) 246 | (if (evenp (length pairs)) 247 | (let (last) 248 | (loop :for (s v) :on pairs :by #'cddr 249 | :if (symbol-object-p s) 250 | :do (setf last (%eval-setq s v env)) 251 | :else :do (error-not-symbol s)) 252 | last) 253 | (error-arg-count pairs)))) 254 | 255 | (defun eval-if (form env) 256 | (case (length form) 257 | ((3 4) (if (eval-form (second form) env) 258 | (eval-form (third form) env) 259 | (eval-form (fourth form) env))) 260 | (T (error-arg-count (rest form))))) 261 | 262 | (defun eval-progn (forms env) 263 | (let (prev) 264 | (dolist (expr forms) 265 | (when prev (eval-form prev env)) 266 | (setf prev expr)) 267 | (eval-form prev env))) 268 | 269 | (defun eval-body (form env) 270 | (multiple-value-bind 271 | (forms doc statics dynamics constants macros) 272 | (parse-body (rest form)) 273 | (declare (ignore doc statics constants macros)) 274 | (if (endp dynamics) 275 | (eval-progn forms env) 276 | (let ((env (make-env :parent env 277 | :vars (mapcar (lambda (v) 278 | (cons v :dynamic)) 279 | dynamics)))) 280 | (eval-progn forms env))))) 281 | 282 | (defun eval-the (form env) 283 | (if (= 3 (length form)) 284 | ;; I'm too lazy to implement this. 285 | ;; TODO: perform type checking 286 | (eval-form (third form) env) 287 | (error-arg-count (rest form)))) 288 | 289 | (defun eval-cons (form env) 290 | (case (car form) 291 | ([lambda] (eval-lambda form env)) 292 | ([quote] (eval-quote form env)) 293 | ([setq] (eval-setq form env)) 294 | ([if] (eval-if form env)) 295 | (([toplevel-expansion-too] 296 | [toplevel-expansion-only] 297 | [body]) 298 | (eval-body form env)) 299 | ([body1] (eval-body1 form env)) 300 | ([let] (eval-let form env)) 301 | ([let*] (eval-let* form env)) 302 | ([letr] (eval-letr form env)) 303 | ([bind] (eval-bind form env)) 304 | ([catch] (eval-catch form env)) 305 | ([throw] (eval-throw form env)) 306 | ([block] (eval-block form env)) 307 | ([return-from] (eval-return-from env)) 308 | ([tagbody] (eval-tagbody form env)) 309 | ([go] (eval-go form env)) 310 | ([unwind-protect] (eval-unwind-protect form env)) 311 | ([mvcall] (eval-mvcall form env)) 312 | ([the] (eval-the form env)) 313 | (T (eval-call (eval-form (car form) env) 314 | (eval-args (cdr form) env))))) 315 | 316 | (defun eval-args (args env) 317 | (cond ((null args) '()) 318 | ((atom args) (let ((form (eval-form args env))) 319 | (if (listp form) 320 | form 321 | (error-not-list form env)))) 322 | (T (cons (eval-form (car args) env) 323 | (eval-args (cdr args) env))))) 324 | 325 | (defun eval-call (f args) 326 | #| TBD 327 | (let* ((f (typecase f 328 | (function-object f) 329 | (instance-object (or (inst-function f) 330 | (error-not-callable f))) 331 | (T (error-not-function f)))) 332 | (required '()) 333 | (rest nil) 334 | (*dynamic-vars* *dynamic-vars*)) 335 | (loop :for (p . rp) :on (fun-args f) 336 | :for (a . ra) :on args 337 | :if (not (is-p a (cddr p))) 338 | :do (error-not-class-of a (cddr p)) 339 | :else if (eq :dynamic (cadr p)) 340 | :do (push (cons (car a) p) *dynamic-vars*) 341 | :else :collect (list* (car p) (cadr p) a) :into req 342 | :finally ) 343 | ) 344 | |# 345 | ) 346 | 347 | (defun eval-form (form env) 348 | (let ((form (expand form env))) 349 | (typecase form 350 | (null nil) 351 | (symbol-object (eval-ref form env)) 352 | (cons (eval-cons form env)) 353 | ((or character array number) form) 354 | (T (lisp-runtime-error 355 | "Invalid lisp object spotted: ~s" form))))) 356 | 357 | (defun eval-form-in-cenv (form env) 358 | (let ((cenv (make-env 359 | :vars (loop :for v :in (env-vars env) 360 | :for vt = (second v) 361 | :when (or (eq vt :constant) 362 | (eq vt :macro)) 363 | :collect v)))) 364 | (eval-form form cenv))) 365 | 366 | (disable-xi-syntax) 367 | -------------------------------------------------------------------------------- /src/xi/objects.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:microlisp) 2 | 3 | (deftype index () '(integer 0 #.(1- array-total-size-limit))) 4 | 5 | (defstruct (symbol-object 6 | (:constructor alloc-sym) 7 | (:conc-name sym-)) 8 | name 9 | (value :unbound) 10 | namespace 11 | assembly) 12 | 13 | (defstruct (function-object 14 | (:constructor alloc-fun) 15 | (:conc-name fun-)) 16 | name 17 | args 18 | env 19 | code) 20 | 21 | (defstruct (instance-object 22 | (:constructor alloc-inst) 23 | (:conc-name inst-)) 24 | function 25 | class 26 | slots) 27 | 28 | (defmacro inst-ref (instance i) 29 | `(svref (inst-slots ,instance) ,i)) 30 | 31 | (defmacro defaccessors (&rest names) 32 | `(progn ,@(loop :with inst = (gensym) 33 | :for name :in names 34 | :for i :from 0 35 | :collect `(defmacro ,name (,inst) 36 | (list 'inst-ref ,inst ,i))))) 37 | -------------------------------------------------------------------------------- /src/xi/package.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | 3 | (defpackage #:microlisp 4 | (:use #:cl) 5 | (:export 6 | )) 7 | -------------------------------------------------------------------------------- /src/xi/symbols.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:microlisp) 2 | 3 | ; 4 | ; We need to store symbols somewhere untils 5 | ; it comes to namespace and assembly definitions. 6 | ; 7 | 8 | (eval-when (:compile-toplevel :load-toplevel :execute) 9 | (defvar *xi-symbols* (make-hash-table :test #'equal)) 10 | (defun %symbol (name) 11 | (declare (type string name)) 12 | (let ((str (coerce name '(simple-array character (*))))) 13 | (or (gethash str *xi-symbols*) 14 | (setf (gethash str *xi-symbols*) 15 | (alloc-sym :name str))))) 16 | (defmethod make-load-form ((object symbol-object) &optional env) 17 | (declare (ignore env)) 18 | `(%symbol ,(sym-name object)))) 19 | 20 | ; 21 | ; syntax sugar for XI symbols 22 | ; 23 | 24 | (eval-when (:compile-toplevel :load-toplevel :execute) 25 | (defvar *prev-readtables* '()) 26 | (defun %enable-xi-syntax () 27 | (push *readtable* *prev-readtables*) 28 | (setf *readtable* (copy-readtable)) 29 | (set-macro-character 30 | #\[ (lambda (s c) 31 | (declare (ignore c)) 32 | (let ((s (coerce 33 | (with-output-to-string (out) 34 | (loop :for c = (read-char s) :do 35 | (when (char= c #\]) (return)) 36 | (write-char c out))) 37 | '(simple-array character (*))))) 38 | (%symbol s)))) 39 | (set-macro-character 40 | #\] (lambda (s c) 41 | (declare (ignore s c)) 42 | (error "Unmatched close bracket.")))) 43 | (defun %disable-xi-syntax () 44 | (unless (endp *prev-readtables*) 45 | (setf *readtable* (pop *prev-readtables*))))) 46 | 47 | (defmacro enable-xi-syntax () 48 | `(eval-when (:compile-toplevel :load-toplevel :execute) 49 | (%enable-xi-syntax))) 50 | 51 | (defmacro disable-xi-syntax () 52 | `(eval-when (:compile-toplevel :load-toplevel :execute) 53 | (%disable-xi-syntax))) 54 | --------------------------------------------------------------------------------