├── .gitignore ├── tests ├── islisp.lsp ├── globals-can-close.lsp ├── imports.lsp ├── exports.lsp ├── phasing.lsp ├── shadowing.lsp ├── dont-be-shadowed.lsp └── hygiene.lsp ├── readtable.lisp ├── README.md ├── core-lisp.asd ├── test.lisp ├── core-lisp-packages.lisp ├── lang.lisp ├── core-lisp-boot.lisp └── core-lisp.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | .overlord 2 | -------------------------------------------------------------------------------- /tests/islisp.lsp: -------------------------------------------------------------------------------- 1 | #lang core-lisp 2 | 3 | (defglobal hello "hello world") 4 | 5 | (:export hello) 6 | -------------------------------------------------------------------------------- /tests/globals-can-close.lsp: -------------------------------------------------------------------------------- 1 | #lang core-lisp 2 | 3 | (defglobal x (lambda () x)) 4 | 5 | (:export x) 6 | -------------------------------------------------------------------------------- /tests/imports.lsp: -------------------------------------------------------------------------------- 1 | #lang core-lisp 2 | 3 | (core-lisp:import m :from "exports.lsp" 4 | :binding (x (cl:function y) (cl:macro-function z))) 5 | 6 | (:export-default (list x (y) (z))) 7 | -------------------------------------------------------------------------------- /tests/exports.lsp: -------------------------------------------------------------------------------- 1 | #lang core-lisp 2 | 3 | ;;; For use with imports.lsp. 4 | 5 | (defglobal x :var) 6 | 7 | (defun y () 8 | :fn) 9 | 10 | (defmacro z () 11 | :macro) 12 | 13 | (:export x #'y (macro-function z)) 14 | -------------------------------------------------------------------------------- /tests/phasing.lsp: -------------------------------------------------------------------------------- 1 | #lang core-lisp 2 | 3 | (defdynamic *count* 4 | (or (ignore-errors (dynamic *count*)) 5 | -1)) 6 | 7 | (defun inc-count () 8 | (setf (dynamic *count*) 9 | (+ (dynamic *count*) 1))) 10 | 11 | (:export #'inc-count) 12 | -------------------------------------------------------------------------------- /tests/shadowing.lsp: -------------------------------------------------------------------------------- 1 | #lang core-lisp 2 | 3 | (defglobal b nil) 4 | 5 | (let ((a 0)) 6 | (macrolet ((mac (name) 7 | `(list ,(alias a) ,name))) 8 | (let ((a 1)) 9 | ;; Should be '(0 1), not '(1 1). 10 | (setq b (mac a))))) 11 | 12 | (:export-default b) 13 | -------------------------------------------------------------------------------- /readtable.lisp: -------------------------------------------------------------------------------- 1 | (in-package :core-lisp) 2 | 3 | (cl:defun sharp-quote (stream sub-char numarg) 4 | (declare (ignore sub-char numarg)) 5 | `(function ,(cl:read stream cl:t cl:nil cl:t))) 6 | 7 | (named-readtables:defreadtable core-lisp 8 | (:merge :standard) 9 | (:dispatch-macro-char #\# #\' #'sharp-quote)) 10 | -------------------------------------------------------------------------------- /tests/dont-be-shadowed.lsp: -------------------------------------------------------------------------------- 1 | #lang core-lisp 2 | 3 | (defglobal syms '(x y z)) 4 | 5 | (defglobal x :right) 6 | 7 | (defun y () :right) 8 | 9 | (defmacro z () :right) 10 | 11 | (defglobal xyz 12 | (lambda (form env) form env 13 | `(list ,(alias x) 14 | (,(function-alias y)) 15 | (,(function-alias z))))) 16 | 17 | (:export syms xyz) 18 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | This is a fork of Pascal Costanza’s [Core Lisp][], a 2 | hygiene-compatible Lisp dialect. It has been forked to work 3 | with [Vernacular][], an experimental module system for Common 4 | Lisp. It serves to show that Vernacular can, in fact, be used to build 5 | Racket-style language towers, despite Common Lisp’s lack of hygiene, 6 | “simply” by embedding a hygiene-compatible language within Common 7 | Lisp. 8 | 9 | Core Lisp is an implementation of [ISLISP][], a standardized Lisp 10 | dialect “culturally compatible” with Common Lisp. That is, while it is 11 | not an exact subset of Common Lisp, it contains no features that make 12 | it unsuitable for implementation in Common Lisp. 13 | 14 | Core Lisp provides a degree of hygiene equivalent to that provided 15 | by [explicit renaming][] or [syntactic closures][]. That’s a lot of 16 | hygiene, but not all the hygiene. You might want to read 17 | *[Towards the Essence of Hygiene][essence]*, to understand where this 18 | approach falls short. (This approach being the one the author terms 19 | “binder renaming with gensym”.) 20 | 21 | [ISLISP]: http://islisp.info/ 22 | [Overlord]: http://github.com/ruricolist/overlord 23 | [Vernacular]: http://github.com/ruricolist/vernacular 24 | [Core Lisp]: http://www.p-cos.net/core-lisp.html 25 | [syntactic closures]: https://en.wikipedia.org/wiki/Syntactic_closure 26 | [explicit renaming]: http://dl.acm.org/citation.cfm?id=1317269 27 | [essence]: http://michaeldadams.org/papers/hygiene/ 28 | -------------------------------------------------------------------------------- /tests/hygiene.lsp: -------------------------------------------------------------------------------- 1 | #lang core-lisp 2 | 3 | (defmacro defcase (name args &body body) args 4 | `(defglobal ,name 5 | (or (ignore-errors 6 | ,@body) 7 | :error))) 8 | 9 | (defcase case-1 () 10 | (let ((x 3)) 11 | (macrolet ((let-inc (u v) 12 | `(let ((,u 2)) 13 | ,v))) 14 | (macrolet ((m (y) 15 | `(let-inc x (* x ,y)))) 16 | (m x))))) 17 | 18 | (defcase case-2 () 19 | (let ((x 3)) 20 | (macrolet ((let-inc (u v) 21 | `(let ((,u 2)) 22 | ,v))) 23 | (macrolet ((m (y) 24 | (let ((x (gensym))) 25 | `(let-inc ,x (* ,x ,y))))) 26 | (m x))))) 27 | 28 | (defcase case-3 () 29 | (let ((x 3)) 30 | (macrolet ((let-inc (u v) v 31 | `(+ 1 ,u))) 32 | (macrolet ((m (y) 33 | (let ((x (gensym))) 34 | `(let-inc ,x (* ,x ,y))))) 35 | (m x))))) 36 | 37 | (defcase case-4 () 38 | (let ((x 3)) 39 | (macrolet ((let-inc (u v) v 40 | `(+ 1 ,u))) 41 | (macrolet ((m (y) 42 | `(let-inc x (* x ,y)))) 43 | (m x))))) 44 | 45 | (defcase case-5 () 46 | (let ((x 3)) 47 | (macrolet ((let-inc (u v) 48 | `(let ((,u (+ 1 ,u))) ,v))) 49 | (macrolet ((m (y) 50 | `(let-inc x (* x ,y)))) 51 | ;; Improper capture of original X. 52 | (m x))))) 53 | 54 | (defcase case-6 () 55 | (let ((x 3)) 56 | (macrolet ((let-inc (u v) 57 | `(let ((,u (+ 1 ,u))) ,v))) 58 | (macrolet ((m (y) 59 | (let ((x (gensym))) 60 | `(let-inc ,x (* ,x ,y))))) 61 | ;; Reference to an unbound variable. 62 | (m x))))) 63 | 64 | (:export-default (list case-1 case-2 case-3 case-4 case-5 case-6)) 65 | -------------------------------------------------------------------------------- /core-lisp.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem #:core-lisp 2 | :name "Core Lisp" 3 | :author "Pascal Costanza" 4 | :description "Hygiene-compatible Lisp dialect embedded in CL." 5 | :maintainer "Paul M. Rodriguez " 6 | :licence " 7 | Copyright (c) 2009 Pascal Costanza 8 | Copyright (c) 2017 Paul M. Rodriguez 9 | 10 | Permission is hereby granted, free of charge, to any person 11 | obtaining a copy of this software and associated documentation 12 | files (the \"Software\"), to deal in the Software without 13 | restriction, including without limitation the rights to use, 14 | copy, modify, merge, publish, distribute, sublicense, and/or 15 | sell copies of the Software, and to permit persons to whom the 16 | Software is furnished to do so, subject to the following 17 | conditions: 18 | 19 | The above copyright notice and this permission notice shall be 20 | included in all copies or substantial portions of the Software. 21 | 22 | THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, 23 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 24 | OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 25 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 26 | HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 27 | WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 28 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 29 | OTHER DEALINGS IN THE SOFTWARE. 30 | " 31 | :components 32 | ((:file "core-lisp-packages") 33 | (:file "core-lisp-boot" :depends-on ("core-lisp-packages")) 34 | (:file "core-lisp" :depends-on ("core-lisp-boot")) 35 | (:file "readtable" :depends-on ("core-lisp-packages")) 36 | (:file "lang" :depends-on ("core-lisp"))) 37 | :in-order-to ((asdf:test-op (asdf:test-op #:core-lisp/test))) 38 | :depends-on (:vernacular :global-vars :alexandria :named-readtables :trivia)) 39 | 40 | (asdf:defsystem #:core-lisp/test 41 | :depends-on ("core-lisp" 42 | "overlord" 43 | "uiop" 44 | "fiveam" 45 | "overlord/tests" 46 | "vernacular/tests") 47 | :perform (asdf:test-op (o c) (uiop:symbol-call :core-lisp/test :run-tests)) 48 | :components 49 | ((:file "test"))) 50 | -------------------------------------------------------------------------------- /test.lisp: -------------------------------------------------------------------------------- 1 | (cl:defpackage :core-lisp/test 2 | (:use :core-lisp :5am) 3 | (:import-from :vernacular/tests :with-imports*) 4 | (:import-from :overlord/tests :with-temp-db :touch) 5 | (:local-nicknames (:v :vernacular))) 6 | (cl:in-package :core-lisp/test) 7 | 8 | (def-suite core-lisp) 9 | (in-suite core-lisp) 10 | 11 | (cl:defun run-tests () 12 | "Entry point for running tests." 13 | ;; NB Has to be a CL function so ASDF can call it by name. 14 | (run! 'core-lisp)) 15 | 16 | (test assure 17 | (is (numberp (assure 42)))) 18 | 19 | (defun iota-h (x lim) 20 | (if (eq x lim) 21 | (list x) 22 | (cons x (iota-h (+ x 1) lim)))) 23 | 24 | (test rfn 25 | (is (equal '(1 2 3 4 5) (iota-h 1 5)))) 26 | 27 | (test abstract-class 28 | (finishes (cl:eval '(defclass () () (:abstractp t))))) 29 | 30 | (def-suite islisp) 31 | 32 | (in-suite islisp) 33 | 34 | (test hello-islisp 35 | (is (equal "hello world" 36 | (with-imports* (m :from "tests/islisp.lsp" :binding (hello)) 37 | hello)))) 38 | 39 | (test islisp-dont-be-shadowed 40 | (is (equal '(:right :right :right) 41 | (with-imports* (m :from "tests/dont-be-shadowed.lsp" 42 | :binding (syms (xyz :as #'expand-xyz))) 43 | (cl:destructuring-bind (x y z) syms 44 | (cl:eval 45 | `(let ((,x :wrong)) (cl:declare (ignorable ,x)) 46 | (flet ((,y () :wrong)) (cl:declare (cl:ignore #',y)) 47 | (macrolet ((,z () :wrong)) 48 | ,(expand-xyz nil nil)))))))))) 49 | 50 | ;;; TODO. 51 | ;; (test islisp-imports 52 | ;; (is (equal '(:var :fn :macro) 53 | ;; (require-default "tests/imports.lsp")))) 54 | 55 | (test islisp-auto-alias 56 | (is (equal '(0 1) 57 | (v:require-default "tests/shadowing.lsp")))) 58 | 59 | (test islisp-hygiene 60 | (touch #1="tests/hygiene.lsp") 61 | ;; Not the desired results, just the ones we expect. 62 | (cl:handler-bind ((cl:warning #'cl:muffle-warning)) 63 | (is (equal '(4 6 :ERROR 4 16 :ERROR) 64 | (v:require-default #1#))))) 65 | 66 | (test islisp-globals-can-close 67 | "Test that globals defined with `defglobal' close over themselves." 68 | (with-imports* (m :from "tests/globals-can-close.lsp" :binding (x)) 69 | (is (eql x (funcall x))))) 70 | 71 | (test islisp-phasing 72 | "Test that state is not preserved across rebuilds." 73 | (v:require-as nil #1="tests/phasing.lsp") 74 | (with-imports* (m :from #1# :binding (#'inc-count)) 75 | (is (= (inc-count) 0)))) 76 | 77 | ;;; Import as package. 78 | 79 | (test import-as-package 80 | (let ((pkg :vernacular-test/as-package)) 81 | (if (cl:find-package pkg) 82 | (cl:delete-package pkg)) 83 | (eval `(vernacular:import-as-package ,pkg 84 | :from "tests/exports.lsp" 85 | :binding (x #'y (macro-function z)))) 86 | (is-true (cl:find-package pkg)) 87 | (is (equal '(:var :fn :macro) 88 | (eval `(list ,(find-symbol (string 'x) pkg) 89 | (,(find-symbol (string 'y) pkg)) 90 | (,(find-symbol (string 'z) pkg)))))))) 91 | -------------------------------------------------------------------------------- /core-lisp-packages.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | 3 | (defpackage :core-lisp-global-definitions (:use)) 4 | 5 | (defpackage :core-lisp 6 | (:use :common-lisp) 7 | #+sbcl (:lock t) 8 | (:shadow 9 | = /= >= <= > < + * - 10 | abs and append apply aref arithmetic-error-operands arithmetic-error-operation 11 | array-dimensions assoc atan atanh block 12 | call-next-method car case catch cdr ceiling cerror char= char/= char< char> char<= char>= 13 | characterp class class-of close cond cons consp cos cosh 14 | defclass defconstant defgeneric define-condition defmacro defmethod defun 15 | elt eq eql equal error exp expt file-length file-position finish-output flet 16 | float floatp floor format funcall function functionp 17 | gcd gensym get-internal-real-time get-internal-run-time get-output-stream-string 18 | get-universal-time go 19 | identity if ignore-errors input-stream-p integerp internal-time-units-per-second isqrt 20 | labels lambda lcm length let let* list listp log 21 | map-into mapc mapcan mapcar mapcon mapl maplist max member min mod 22 | next-method-p nil not open-stream-p output-stream-p nreverse null numberp 23 | or probe-file progn quote 24 | read read-byte read-char read-line return-from reverse round 25 | setf setq sin sinh sqrt stream-error-stream streamp 26 | string= string/= string< string> string>= string<= stringp subseq symbolp 27 | t tagbody tan tanh the throw truncate unwind-protect vector write-byte 28 | 29 | ; extras 30 | 31 | caaaar caaadr caaar caadar caaddr caadr caar cadaar cadadr cadar caddar cadddr caddr cadr 32 | cdaaar cdaadr cdaar cdadar cdaddr cdadr cdar cddaar cddadr cddar cdddar cddddr cdddr cddr 33 | 34 | ;; Vernacular 35 | eval-when symbol-function macro-function import 36 | ) 37 | (:export 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | &rest *most-positive-float* *most-negative-float* *pi* 49 | = /= >= <= > < + * - 50 | abs and append apply aref arithmetic-error-operands arithmetic-error-operation 51 | array-dimensions assoc assure atan atan2 atanh 52 | basic-array-p basic-array*-p basic-vector-p block 53 | call-next-method car case case-using catch cdr ceiling cerror 54 | char= char/= char< char> char<= char>= char-index characterp 55 | class class-of close cond condition-continuable cons consp continue-condition 56 | convert cos cosh create create-array create-list create-string 57 | create-string-input-stream create-string-output-stream create-vector 58 | defclass defconstant defdynamic defgeneric defglobal define-condition 59 | defmacro defmethod defun div domain-error-expected-class domain-error-object 60 | dynamic dynamic-let 61 | elt eq eql equal error error-output exp expt 62 | file-length file-position finish-output flet float floatp floor for 63 | format format-char format-float format-fresh-line format-integer format-object format-tab 64 | funcall function functionp 65 | garef gcd general-array*-p general-vector-p generic-function-p gensym 66 | get-internal-real-time get-internal-run-time get-output-stream-string 67 | get-universal-time go 68 | identity if ignore-errors initialize-object input-stream-p instancep integerp 69 | internal-time-units-per-second isqrt 70 | labels lambda lcm length let let* list listp log 71 | map-into mapc mapcan mapcar mapcon mapl maplist max member min mod 72 | next-method-p nil not nreverse null numberp 73 | open-stream-p open-input-file open-io-file open-output-file 74 | open-stream-p or output-stream-p 75 | parse-number preview-char probe-file progn property quote quotient 76 | read read-byte read-char read-line reciprocal remove-property 77 | return-from reverse round 78 | set-aref set-car set-cdr set-dynamic set-elt set-file-position set-garef set-property setf setq 79 | signal-condition simple-error-format-arguments simple-error-format-string 80 | sin sinh sqrt standard-input standard-output stream-error-stream stream-ready-p streamp 81 | string= string/= string< string> string>= string<= 82 | string-append string-index stringp subclassp subseq symbolp 83 | t tagbody tan tanh the throw truncate undefined-entity-name unwind-protect vector 84 | while with-error-output with-handler 85 | with-open-input-file with-open-io-file with-open-output-file 86 | with-standard-input with-standard-output write-byte 87 | 88 | ; extras 89 | 90 | alias function-alias block-alias tag-alias 91 | 92 | ;; Disabled in favor of vernacular:import. 93 | ;; import-variable import-symbol-macro import-function import-macro 94 | ;; with-imported-variables with-imported-symbol-macros 95 | ;; with-imported-functions with-imported-macros with-imported-block 96 | 97 | &body &environment &whole 98 | caaaar caaadr caaar caadar caaddr caadr caar cadaar cadadr cadar caddar cadddr caddr cadr 99 | cdaaar cdaadr cdaar cdadar cdaddr cdadr cdar cddaar cddadr cddar cdddar cddddr cdddr cddr 100 | 101 | in-package macroexpand macroexpand-1 macrolet symbol-macrolet 102 | 103 | ;; Vernacular. 104 | 105 | read-module module-progn import macro-function)) 106 | 107 | (defpackage :core-lisp-user 108 | (:use :core-lisp)) 109 | -------------------------------------------------------------------------------- /lang.lisp: -------------------------------------------------------------------------------- 1 | (in-package :core-lisp) 2 | 3 | (cl:defparameter *compile-top-level* t) 4 | 5 | (cl:defun package-globals (package) 6 | (cl:let* ((package-name (package-name package)) 7 | (prefix (format nil "~a::" package-name))) 8 | (loop for sym being the present-symbols of *core-lisp-global-package* 9 | for name = (symbol-name sym) 10 | when (serapeum:string^= prefix name) 11 | collect sym))) 12 | 13 | (cl:defun reset-package-globals (package) 14 | (loop with global-package = *core-lisp-global-package* 15 | for sym in (package-globals package) 16 | do (unintern sym global-package) 17 | finally (return package))) 18 | 19 | (cl:defun read-module (source stream) 20 | (cl:let* ((use-list (list (find-package :core-lisp))) 21 | (package (vernacular:reset-file-package source :use-list use-list)) 22 | (readtable (named-readtables:find-readtable 'core-lisp))) 23 | ;; I can't come up with an example where this could matter, but 24 | ;; it's probably better to start clean. 25 | (reset-package-globals package) 26 | `(module-progn 27 | ,@(vernacular:slurp-stream stream 28 | :readtable readtable 29 | :package package)))) 30 | 31 | (cl:defclass core-lisp-module () 32 | ((package :initarg :package :type package) 33 | (default-export :initarg :default-export))) 34 | 35 | (defun find-external-symbol (name package) 36 | (setf name (string name)) 37 | (or (serapeum:find-external-symbol name package) 38 | (cl:error "No symbol named ~a exported from ~s." name package))) 39 | 40 | (serapeum:defmethods core-lisp-module (self package default-export) 41 | (:method vernacular:module-exports (self) 42 | (append (vernacular:module-exports package) 43 | (serapeum:collecting 44 | (do-external-symbols (sym package) 45 | (alexandria:when-let (alias (get-alias sym '%aliases% nil)) 46 | (when (boundp alias) 47 | (collect sym))))))) 48 | (:method vernacular:module-ref (self name) 49 | (vernacular:module-ref-ns self name nil)) 50 | (:method vernacular:module-ref-ns (self name (ns cl:null)) 51 | ;; This is more complicated than `symbol-value' because of global 52 | ;; lexicals. 53 | (let* ((sym (find-external-symbol name package)) 54 | (alias (or (get-alias sym '%aliases% nil) 55 | sym))) 56 | (symbol-value alias))) 57 | (:method vernacular:module-ref-ns (self (name (cl:eql 'vernacular:default)) (ns cl:null)) 58 | default-export) 59 | (:method vernacular:module-ref-ns (self name (ns (cl:eql 'cl:function))) 60 | (symbol-function (find-external-symbol name package))) 61 | (:method vernacular:module-ref-ns (self name (ns (cl:eql 'cl:macro-function))) 62 | (macro-function (find-external-symbol name package)))) 63 | 64 | (cl:defmacro module-progn (&body body) 65 | ;; Variable-only at the moment. 66 | (cl:let* ((export-forms 67 | (loop for form in body 68 | if (and (consp form) 69 | (eql (first form) :export)) 70 | collect form)) 71 | (export-default-form 72 | (loop for form in body 73 | if (and (consp form) (eql (first form) :export-default)) 74 | return form)) 75 | (meta-forms 76 | (if export-default-form 77 | (cons export-default-form export-forms) 78 | export-forms)) 79 | (body 80 | (remove-if (lambda (form) 81 | (member form meta-forms)) 82 | body)) 83 | (exports 84 | (loop for form in export-forms 85 | append (rest form)))) 86 | (assert (not (and export-forms export-default-form))) 87 | (with-unique-names (source pkg) 88 | `(progn 89 | ,@body 90 | (setq vernacular:*module* 91 | (cl:let* ((,source ,vernacular:*source*) 92 | (,pkg (vernacular:intern-file-package ,source)) 93 | (*package* ,pkg)) 94 | ,@(loop for export in exports 95 | collect (trivia:ematch export 96 | ((type symbol) 97 | `(export ',export)) 98 | ((cl:list 'function (cl:and symbol (type symbol))) 99 | `(export ',symbol)) 100 | ((cl:list 'macro-function (cl:and symbol (type symbol))) 101 | `(export ',symbol)))) 102 | (make-instance 'core-lisp-module 103 | :package ,pkg 104 | ,@(and export-default-form 105 | `(:default-export 106 | (progn 107 | ,@(rest export-default-form))))))))))) 108 | 109 | (defmacro import (m &rest args) 110 | `(macrolet ((vernacular/cl:defmacro (name args &body body) 111 | (declare (ignore args body)) 112 | ;; ISLISP's defmacro supports neither &environment 113 | ;; nor &whole nor even &body. 114 | (let ((key (alexandria:make-keyword name)) 115 | (env nil)) 116 | `(defmacro ,name (&rest args) 117 | (list 'funcall 118 | '(vernacular:module-ref* ,',m ',key) 119 | (list 'quote (cons ',name args)) 120 | ,env)))) 121 | (vernacular/cl:defun (name args &body body) 122 | (list* 'defun name args body)) 123 | (vernacular/cl:defalias (name expr) 124 | `(let ((fn ,expr)) 125 | (defun ,name (&rest args) 126 | (apply fn args)))) 127 | (vernacular/cl:def (name init) 128 | (list 'defglobal name init)) 129 | (vernacular/cl:define-symbol-macro (name expr) 130 | (list 'define-symbol-macro name expr))) 131 | (vernacular:import ,m ,@args))) 132 | -------------------------------------------------------------------------------- /core-lisp-boot.lisp: -------------------------------------------------------------------------------- 1 | (in-package :core-lisp) 2 | 3 | (cl:defmacro with-unique-names (names &body body) 4 | `(let ,(loop for name in names 5 | collect `(,name (cl:gensym ,(symbol-name name)))) 6 | ,@body)) 7 | 8 | (cl:defmacro rebinding (vars &body body) 9 | (loop for var in vars 10 | for name = (cl:gensym (symbol-name var)) 11 | collect `(,name ,var) into renames 12 | collect ``(,,var ,,name) into temps 13 | finally (return `(let ,renames 14 | (with-unique-names ,vars 15 | `(let (,,@temps) ,,@body)))))) 16 | 17 | (cl:defmacro eval-when (situations &body body) 18 | `(cl:eval-when ,situations 19 | ,@body)) 20 | 21 | (defvar *core-lisp-global-package* 22 | (find-package "CORE-LISP-GLOBAL-DEFINITIONS")) 23 | 24 | (cl:defgeneric global (name) 25 | (:method ((symbol cl:symbol)) 26 | (intern (cl:format cl:nil "~A::~A" 27 | (package-name (symbol-package symbol)) 28 | (symbol-name symbol)) 29 | *core-lisp-global-package*)) 30 | (:method ((name cl:cons)) 31 | `(cl:setf ,(global (cl:cadr name))))) 32 | 33 | (cl:setf (find-class ') (find-class 'cl:t) 34 | (find-class ') (find-class 'array) 35 | (find-class ') (find-class 'cl:vector) 36 | (find-class ') (find-class 'cl:vector) 37 | (find-class ') (find-class 'string) 38 | (find-class ') (find-class 'built-in-class) 39 | (find-class ') (find-class 'character) 40 | (find-class ') (find-class 'cl:function) 41 | (find-class ') (find-class 'generic-function) 42 | (find-class ') (find-class 'standard-generic-function) 43 | (find-class ') (find-class 'cl:list) 44 | (find-class ') (find-class 'cl:cons) 45 | (find-class ') (find-class 'cl:null) 46 | (find-class ') (find-class 'symbol) 47 | (find-class ') (find-class 'number) 48 | (find-class ') (find-class 'cl:float) 49 | (find-class ') (find-class 'integer) 50 | (find-class ') (find-class 'serious-condition) 51 | (find-class ') (find-class 'cl:error) 52 | (find-class ') (find-class 'arithmetic-error) 53 | (find-class ') (find-class 'division-by-zero) 54 | (find-class ') (find-class 'floating-point-overflow) 55 | (find-class ') (find-class 'floating-point-underflow) 56 | (find-class ') (find-class 'control-error) 57 | (find-class ') (find-class 'parse-error) 58 | (find-class ') (find-class 'program-error) 59 | (find-class ') (find-class 'type-error) 60 | (find-class ') (find-class 'cell-error) 61 | (find-class ') (find-class 'unbound-variable) 62 | (find-class ') (find-class 'undefined-function) 63 | (find-class ') (find-class 'simple-error) 64 | (find-class ') (find-class 'stream-error) 65 | (find-class ') (find-class 'end-of-file) 66 | (find-class ') (find-class 'storage-condition) 67 | (find-class ') (find-class 'standard-class) 68 | (find-class ') (find-class 'standard-object) 69 | (find-class ') (find-class 'stream)) 70 | 71 | (defvar *core-lisp-lambda-list-keywords* 72 | '(&body &environment &rest &whole)) 73 | 74 | (defvar *lambda-list-keyword-map* 75 | (loop for keyword in *core-lisp-lambda-list-keywords* 76 | collect (cl:cons (intern (cl:subseq (symbol-name keyword) 1) :keyword) keyword))) 77 | 78 | (defvar *error-ll*) 79 | 80 | (cl:defun ll-keywordp (symbol) 81 | (cl:let ((symbol-name (symbol-name symbol))) 82 | (cl:eql (when (cl:> (cl:length symbol-name) 0) 83 | (cl:aref symbol-name 0)) 84 | #\&))) 85 | 86 | (cl:defun ll-element-err (element) 87 | (cl:error "Unexpected element ~S in lambda list ~S." element *error-ll*)) 88 | 89 | (cl:defun ll-end-err (&optional tail) 90 | (cl:if tail 91 | (cl:error "Unexpected tail ~S in lambda-list ~S." tail *error-ll*) 92 | (cl:error "Unexpected NIL / end in lambda list ~S." *error-ll*))) 93 | 94 | (cl:defun ll-duplicate-err (var) 95 | (cl:error "Duplicate variable ~S in lambda list ~S." var *error-ll*)) 96 | 97 | (cl:defun ll-keyword (keyword) 98 | (cl:if (cl:and (cl:symbolp keyword) (keywordp keyword)) 99 | (cl:let ((ll-keyword (cl:cdr (cl:assoc keyword *lambda-list-keyword-map*)))) 100 | (cl:if ll-keyword ll-keyword (ll-element-err keyword))) 101 | keyword)) 102 | 103 | (cl:defun symbol-not-null (element) 104 | (cl:if (cl:and element (cl:symbolp element)) element 105 | (ll-element-err element))) 106 | 107 | (cl:defun var-symbol (element) 108 | (cl:if element 109 | (cl:if (cl:and (cl:symbolp element) 110 | (cl:not (keywordp element)) 111 | (cl:not (ll-keywordp element))) 112 | element (ll-element-err element)) 113 | (ll-end-err))) 114 | 115 | (cl:defun gf-name (name) 116 | (cl:if (cl:consp name) 117 | (cl:cond ((cl:eq (cl:car name) 'cl:setf) name) 118 | ((cl:eq (cl:car name) 'setf) `(cl:setf ,(cl:cadr name))) 119 | (cl:t (cl:error "Illegal function name ~S." name))) 120 | name)) 121 | 122 | (cl:defun check-specializer (element) 123 | (cl:if (cl:and (cl:car element) 124 | (cl:symbolp (cl:car element)) 125 | (cl:not (keywordp (cl:car element))) 126 | (cl:not (ll-keywordp (cl:car element))) 127 | (cl:null (cl:cddr element))) 128 | element (ll-element-err element))) 129 | 130 | (cl:defun check-duplicate (var aliases) 131 | (when (cl:member var aliases :key #'cl:car) 132 | (ll-duplicate-err var))) 133 | 134 | (cl:defun parse-element (rest) 135 | (unless (cl:listp rest) (ll-end-err rest)) 136 | (cl:if (cl:null rest) '() 137 | (cl:let ((element (cl:car rest))) 138 | (cl:if (cl:consp element) 139 | (cl:list 'specializer 140 | (check-specializer element) 141 | (cl:cdr rest)) 142 | (cl:let ((element (symbol-not-null element))) 143 | (cl:if (cl:or (keywordp element) (ll-keywordp element)) 144 | (cl:list element 145 | (var-symbol (cl:cadr rest)) 146 | (cl:cddr rest)) 147 | (cl:list 'var element (cl:cdr rest)))))))) 148 | 149 | (cl:defun parse-lambda-list (ll &key ((:error-ll *error-ll*) ll) (specializers cl:nil) (rest-keys '(&rest))) 150 | (loop for (kind var-spec rest) = (parse-element ll) then (parse-element rest) 151 | for var = (cl:if (cl:eq kind 'specializer) 152 | (cl:if specializers (cl:car var-spec) 153 | (ll-element-err var)) 154 | var-spec) 155 | for alias = (when kind (copy-symbol var)) 156 | while kind do (check-duplicate var aliases) 157 | unless (cl:member kind '(var specializer)) collect (ll-keyword kind) into new-lambda-list end 158 | if (cl:eq kind 'specializer) 159 | collect (cl:cons alias (cl:cdr var-spec)) into new-lambda-list 160 | and collect (cl:list var alias) into aliases 161 | else 162 | collect alias into new-lambda-list 163 | and collect (cl:list var alias) into aliases 164 | while (cl:member kind '(var specializer)) 165 | finally 166 | (when kind 167 | (unless (cl:member (ll-keyword kind) rest-keys) 168 | (ll-element-err kind)) 169 | (when rest (ll-end-err rest))) 170 | (return (values new-lambda-list aliases)))) 171 | 172 | (cl:defun parse-macro-lambda-list (ll &aux (*error-ll* ll)) 173 | (cl:let ((rest-ll ll) 174 | (element (parse-element ll)) 175 | whole-var whole-alias env-var env-alias) 176 | (when element 177 | (destructuring-bind (kind var rest) element 178 | (when (cl:member kind '(:whole &whole)) 179 | (cl:setq rest-ll rest 180 | whole-var var 181 | whole-alias (copy-symbol var) 182 | element (parse-element rest)))) 183 | (when element 184 | (destructuring-bind (kind var rest) element 185 | (when (cl:member kind '(:environment &environment)) 186 | (cl:setq rest-ll rest 187 | env-var var 188 | env-alias (copy-symbol var) 189 | element (parse-element rest)))) 190 | (when (cl:and (cl:or whole-var env-var) (cl:eq whole-var env-var)) 191 | (ll-duplicate-err whole-var)) 192 | (multiple-value-bind 193 | (new-lambda-list aliases) 194 | (parse-lambda-list rest-ll :error-ll ll :rest-keys '(&rest &body)) 195 | (check-duplicate env-var aliases) 196 | (check-duplicate whole-var aliases) 197 | (values 198 | (nconc (when whole-var (cl:list '&whole whole-alias)) 199 | (when env-var (cl:list '&environment env-alias)) 200 | new-lambda-list) 201 | (nconc (when whole-var (cl:list (cl:list whole-var whole-alias))) 202 | (when env-var (cl:list (cl:list env-var env-alias))) 203 | aliases))))))) 204 | 205 | (cl:defun err-illegal-slot-spec (slot-spec w) 206 | (cl:error "Invalid slot spec ~S in ~S." slot-spec w)) 207 | 208 | (cl:defun parse-slot-spec (w slot-spec) 209 | (cl:cond ((cl:null slot-spec) (err-illegal-slot-spec slot-spec w)) 210 | ((cl:symbolp slot-spec) (cl:list slot-spec '() '())) 211 | ((cl:consp slot-spec) 212 | (unless (cl:and (cl:car slot-spec) (cl:symbolp (cl:car slot-spec))) 213 | (err-illegal-slot-spec slot-spec w)) 214 | (loop for (key value) on (cl:cdr slot-spec) by #'cl:cddr 215 | nconc (cl:if (cl:member key '(:accessor :reader :writer)) 216 | `(,key ,(global value)) 217 | `(,key ,value)) into new-slot-spec 218 | when (cl:member key '(:accessor :reader)) 219 | collect value into readers 220 | when (cl:member key '(:accessor :writer)) 221 | collect (cl:if (cl:eq key :accessor) 222 | `(cl:setf ,value) (gf-name value)) into writers 223 | finally (return (cl:list `(,(cl:car slot-spec) ,@new-slot-spec) readers writers)))) 224 | (cl:t (err-illegal-slot-spec slot-spec w)))) 225 | 226 | (cl:defmacro -import-variable- (name alias) 227 | `(cl:progn 228 | (eval-when (:compile-toplevel :load-toplevel :execute) 229 | (define-symbol-macro ,name ,alias) 230 | (cl:setf (get ',name '%aliases%) ',alias) 231 | ',name))) 232 | 233 | (cl:defmacro -import-symbol-macro- (name alias) 234 | `(cl:progn 235 | (eval-when (:compile-toplevel :load-toplevel :execute) 236 | (define-symbol-macro ,name ,alias) 237 | (cl:setf (get ',name '%aliases%) ',alias) 238 | ',name))) 239 | 240 | (cl:defmacro -import-function- (fname falias &optional (lambda-list '() lambda-list-p)) 241 | (assert (cl:or (cl:and (cl:symbolp fname) (cl:symbolp falias)) 242 | (cl:and (cl:consp fname) (cl:consp falias)))) 243 | (cl:let ((name (cl:if (cl:symbolp fname) fname (cl:cadr fname))) 244 | (alias (cl:if (cl:symbolp falias) falias (cl:cadr falias)))) 245 | `(cl:progn 246 | ,(cl:if lambda-list-p 247 | (loop for (element . rest) on lambda-list 248 | for restp = (cl:member element '(:rest &rest)) 249 | until restp 250 | collect element into required-vars 251 | finally (return 252 | (cl:if restp 253 | (cl:let ((rest-var (cl:car rest))) 254 | (cl:if (cl:symbolp fname) 255 | `(cl:defmacro ,fname (,@required-vars &rest ,rest-var) 256 | `(,',falias ,,@required-vars ,@,rest-var)) 257 | `(defsetf ,name (,@(cl:cdr required-vars) &rest ,rest-var) 258 | (,(cl:car required-vars)) 259 | `(cl:setf (,',alias ,,@(cl:cdr required-vars) ,@,rest-var) 260 | ,,(cl:car required-vars))))) 261 | (cl:if (cl:symbolp fname) 262 | `(cl:defmacro ,fname (,@lambda-list) 263 | `(,',falias ,,@lambda-list)) 264 | `(defsetf ,name (,@(cl:cdr lambda-list)) (,(cl:car lambda-list)) 265 | `(cl:setf (,',alias ,,@(cl:cdr lambda-list)) 266 | ,,(cl:car lambda-list))))))) 267 | (cl:let ((rest-var (cl:gensym))) 268 | (cl:if (cl:symbolp fname) 269 | `(cl:defmacro ,fname (&rest ,rest-var) 270 | `(,',falias ,@,rest-var)) 271 | (cl:let ((store-var (cl:gensym))) 272 | `(defsetf ,fname (&rest ,rest-var) (,store-var) 273 | `(cl:setf (,',alias ,@,rest-var) ,,store-var)))))) 274 | (eval-when (:compile-toplevel :load-toplevel :execute) 275 | (cl:setf (get ',name '%function-aliases%) ',alias)) 276 | ',fname))) 277 | 278 | (cl:defmacro -import-generic-function- (fname falias &optional (lambda-list '() lambda-list-p)) 279 | (assert (cl:or (cl:and (cl:symbolp fname) (cl:symbolp falias)) 280 | (cl:and (cl:consp fname) (cl:consp falias)))) 281 | (cl:let ((name (cl:if (cl:symbolp fname) fname (cl:cadr fname))) 282 | (alias (cl:if (cl:symbolp falias) falias (cl:cadr falias)))) 283 | `(cl:progn 284 | ,(cl:if lambda-list-p 285 | `(defgeneric ,fname (,@lambda-list)) 286 | `(defgeneric ,fname (&rest ,(cl:gensym)))) 287 | (cl:setf (cl:fdefinition ',(global fname)) (cl:fdefinition ',falias)) 288 | (eval-when (:compile-toplevel :load-toplevel :execute) 289 | (cl:setf (get ',name '%function-aliases%) ',alias)) 290 | ',fname))) 291 | 292 | (cl:defmacro -import-macro- (fname falias &optional (lambda-list '() lambda-list-p)) 293 | (cl:if lambda-list-p 294 | (loop with whole-var 295 | with env-var 296 | with body-var 297 | with rest-var 298 | for (elm1 elm2) on lambda-list 299 | for element = (ll-keyword elm1) 300 | if (cl:eq element '&whole) do (cl:setq whole-var elm2) 301 | else if (cl:eq element '&environment) do (cl:setq env-var elm2) 302 | else if (cl:eq element '&body) do (cl:setq body-var elm2) 303 | else if (cl:eq element '&rest) do (cl:setq rest-var elm2) 304 | else unless (cl:member element (cl:list whole-var env-var body-var rest-var)) 305 | collect element into required-vars 306 | finally 307 | (cl:let ((new-whole-var (cl:if whole-var whole-var 'whole-form)) 308 | (new-env-var (cl:if env-var env-var 'environment))) 309 | (return 310 | `(cl:progn 311 | (cl:defmacro ,fname (&whole ,new-whole-var &environment ,new-env-var 312 | ,@required-vars 313 | ,@(when body-var `(&body ,body-var)) 314 | ,@(when rest-var `(&rest ,rest-var))) 315 | (declare (ignore ,@required-vars 316 | ,@(when body-var (cl:list body-var)) 317 | ,@(when rest-var (cl:list rest-var)))) 318 | (cl:funcall (cl:macro-function ',falias ,new-env-var) ,new-whole-var ,new-env-var)) 319 | (eval-when (:compile-toplevel :load-toplevel :execute) 320 | (cl:setf (get ',fname '%function-aliases%) ',falias)) 321 | ',fname)))) 322 | (cl:let ((whole-var (cl:gensym)) (env-var (cl:gensym)) (body-var (cl:gensym))) 323 | `(cl:progn 324 | (cl:defmacro ,fname (&whole ,whole-var &environment ,env-var &body ,body-var) 325 | (declare (ignore ,body-var)) 326 | (cl:funcall (cl:macro-function ',falias ,env-var) ,whole-var ,env-var)) 327 | (eval-when (:compile-toplevel :load-toplevel :execute) 328 | (cl:setf (get ',fname '%function-aliases%) ',falias) 329 | ',fname))))) 330 | 331 | (cl:defmacro -with-imported-variables- ((&rest bindings) &body body &environment env) 332 | (cl:let ((old-aliases (macroexpand '%aliases% env))) 333 | `(locally (declare #+sbcl (sb-ext:disable-package-locks %aliases%)) 334 | (symbol-macrolet ((%aliases% ,(revappend bindings old-aliases))) 335 | (declare (ignorable %aliases%)) 336 | (symbol-macrolet ,bindings ,@body))))) 337 | 338 | (cl:defmacro -with-imported-symbol-macros- ((&rest bindings) &body body &environment env) 339 | (cl:let ((old-aliases (macroexpand '%aliases% env))) 340 | `(locally (declare #+sbcl (sb-ext:disable-package-locks %aliases%)) 341 | (symbol-macrolet ((%aliases% ,(revappend bindings old-aliases))) 342 | (declare (ignorable %aliases%)) 343 | (symbol-macrolet ,bindings ,@body))))) 344 | 345 | (cl:defmacro -with-imported-functions- ((&rest bindings) &body body &environment env) 346 | (cl:let ((old-aliases (macroexpand '%function-aliases% env))) 347 | `(locally (declare #+sbcl (sb-ext:disable-package-locks %function-aliases%)) 348 | (symbol-macrolet ((%function-aliases% ,(revappend bindings old-aliases))) 349 | (declare (ignorable %function-aliases%)) 350 | (cl:macrolet ,(loop for (fun alias) in bindings 351 | collect `(,fun (&rest args) `(,',alias ,@args))) 352 | ,@body))))) 353 | 354 | (cl:defvar -arguments-for-local-macros-) 355 | 356 | (cl:defmacro expand-local-macro (name &environment env) 357 | `',(macroexpand `(,name ,@-arguments-for-local-macros-) env)) 358 | 359 | (cl:defmacro -with-imported-macros- ((&rest bindings) &body body &environment env) 360 | (cl:let ((old-aliases (macroexpand '%function-aliases% env))) 361 | `(locally (declare #+sbcl (sb-ext:disable-package-locks %function-aliases%)) 362 | (symbol-macrolet ((%function-aliases% ,(revappend bindings old-aliases))) 363 | (declare (ignorable %function-aliases%)) 364 | (cl:macrolet ,(loop for (macro alias) in bindings 365 | collect `(,macro (&rest -arguments-for-local-macros-) (expand-local-macro ,alias))) 366 | ,@body))))) 367 | 368 | (cl:defmacro -with-imported-block- ((block-name block-alias) &body body &environment env) 369 | (cl:let ((old-aliases (macroexpand '%block-aliases% env))) 370 | `(cl:block ,block-name 371 | (locally (declare #+sbcl (sb-ext:disable-package-locks %block-aliases%)) 372 | (symbol-macrolet ((%block-aliases% ,(cl:cons `(,block-name ,block-alias) old-aliases))) 373 | ,@body))))) 374 | 375 | (cl:defmacro -defmacro- (macro-name lambda-list &body body) 376 | (cl:let ((macro-alias (global macro-name))) 377 | (multiple-value-bind 378 | (new-lambda-list new-aliases) 379 | (parse-macro-lambda-list lambda-list) 380 | `(cl:progn 381 | (cl:defmacro ,macro-alias ,new-lambda-list 382 | (-with-imported-variables- ,new-aliases ,@body)) 383 | (-import-macro- ,macro-name ,macro-alias ,lambda-list))))) 384 | 385 | (cl:defun expand-body (new-aliases old-aliases body) 386 | `(locally (declare #+sbcl (sb-ext:disable-package-locks %aliases%)) 387 | (symbol-macrolet ((%aliases% ,(revappend new-aliases old-aliases))) 388 | (declare (ignorable %aliases%)) 389 | (symbol-macrolet ,new-aliases ,@body)))) 390 | 391 | (cl:defun process-lambda (env lambda-list body) 392 | (cl:let ((old-aliases (macroexpand '%aliases% env))) 393 | (multiple-value-bind 394 | (new-lambda-list new-aliases) 395 | (parse-lambda-list lambda-list) 396 | (values new-lambda-list (expand-body new-aliases old-aliases body))))) 397 | 398 | (cl:defun expand-method-body (qualifiers new-aliases old-aliases body) 399 | (cl:let ((form (expand-body new-aliases old-aliases body))) 400 | (cl:if (cl:or (cl:null qualifiers) (cl:member :around qualifiers)) 401 | `(-with-imported-functions- ((call-next-method cl:call-next-method) 402 | (next-method-p cl:next-method-p)) 403 | ,form) 404 | form))) 405 | 406 | (cl:defun expand-defclass (w class-name superclasses options &optional (conditionp cl:nil)) 407 | ;; TODO Actually implement abstract classes. 408 | (when (cl:find :abstractp options :key #'cl:car) 409 | (cl:setf options (cl:remove :abstractp options :key #'cl:car))) 410 | (unless (cl:and (cl:symbolp class-name) 411 | (cl:listp superclasses) 412 | (every #'cl:symbolp superclasses) 413 | options 414 | (cl:listp (cl:car options)) 415 | (cl:listp (cl:cdr options)) 416 | (loop for option in (cl:cdr options) 417 | always (cl:and (cl:consp option) 418 | (cl:car option) 419 | (cl:symbolp (cl:car option))))) 420 | (cl:error "Malformed definition: ~S." w)) 421 | (loop for slot-spec in (cl:car options) 422 | for (new-slot-spec readers writers) = (parse-slot-spec w slot-spec) 423 | collect new-slot-spec into new-slot-specs 424 | nconc readers into reader-gfs 425 | nconc writers into writer-gfs 426 | finally (return `(cl:progn 427 | ,@(loop for gf in reader-gfs 428 | collect `(defgeneric ,gf (object))) 429 | ,@(loop for gf in writer-gfs 430 | collect `(defgeneric ,gf (new-value object))) 431 | (,(cl:if conditionp 'cl:define-condition 'cl:defclass) 432 | ,class-name ,superclasses ,new-slot-specs ,@(cl:cdr options)))))) 433 | -------------------------------------------------------------------------------- /core-lisp.lisp: -------------------------------------------------------------------------------- 1 | (in-package :core-lisp) 2 | 3 | (cl:defun get-alias (name namespace env) 4 | (cl:or (cl:cadr (cl:assoc name (macroexpand namespace env))) 5 | (get name namespace))) 6 | 7 | (cl:defun eget-alias (name namespace kind env) 8 | (cl:or (cl:cadr (cl:assoc name (macroexpand namespace env))) 9 | (get name namespace) 10 | (cl:error "No ~S available for symbol ~S." kind name))) 11 | 12 | (cl:defmacro define-alias-namespace (namespace accessor) 13 | `(cl:progn 14 | (define-symbol-macro ,namespace ()) 15 | (-defmacro- ,accessor (&environment env name) 16 | `',(eget-alias name ',namespace ',accessor env)))) 17 | 18 | (define-alias-namespace %aliases% alias) 19 | (define-alias-namespace %function-aliases% function-alias) 20 | (define-alias-namespace %block-aliases% block-alias) 21 | 22 | (-import-macro- import-variable -import-variable- (name alias)) 23 | (-import-macro- import-symbol-macro -import-symbol-macro- (name alias)) 24 | (-import-macro- import-function -import-function- (fname falias &rest lambda-list)) 25 | (-import-macro- import-generic-function -import-generic-function- (fname falias &rest lambda-list)) 26 | (-import-macro- import-macro -import-macro- (fname falias &rest lambda-list)) 27 | (-import-macro- with-imported-variables -with-imported-variables- (bindings &body body)) 28 | (-import-macro- with-imported-symbol-macros -with-imported-symbol-macros- (bindings &body body)) 29 | (-import-macro- with-imported-functions -with-imported-functions- (bindings &body body)) 30 | (-import-macro- with-imported-macros -with-imported-macros- (bindings &body body)) 31 | (-import-macro- with-imported-block -with-imported-block- (binding &body body)) 32 | (-import-macro- defmacro -defmacro- (macro-name lambda-list &body body)) 33 | 34 | (defmacro lambda (&environment env lambda-list &body body) 35 | (multiple-value-bind 36 | (new-lambda-list new-body) 37 | (process-lambda env lambda-list body) 38 | `(cl:lambda ,new-lambda-list ,new-body))) 39 | 40 | (defmacro defglobal (name &body form) 41 | (assert (cl:null (cl:cdr form))) 42 | (cl:let ((alias (global name)) 43 | (defglobal 44 | (cl:if (constantp form) 45 | ;; Use the compile-time version if the form is constant. 46 | 'global-vars:define-global-parameter 47 | 'global-vars:define-global-parameter*))) 48 | `(cl:progn 49 | (import-variable ,name ,alias) 50 | (,defglobal ,alias ,(cl:car form)) 51 | ',name))) 52 | 53 | (defmacro defconstant (name &body form) 54 | (assert (cl:null (cl:cdr form))) 55 | (cl:let ((alias (global name))) 56 | `(cl:progn 57 | (import-variable ,name ,alias) 58 | (global-vars:define-global-var ,alias ,(cl:car form)) 59 | ',name))) 60 | 61 | (defmacro defun (&environment env name lambda-list &body body) 62 | (cl:let ((function-alias (global name))) 63 | (multiple-value-bind 64 | (new-lambda-list new-body) 65 | (process-lambda env lambda-list body) 66 | `(cl:progn 67 | (import-function ,name ,function-alias ,lambda-list) 68 | (cl:defun ,function-alias ,new-lambda-list ,new-body))))) 69 | 70 | (defmacro defgeneric (&whole w &environment env name lambda-list &body options) 71 | (unless (every #'cl:consp options) 72 | (cl:error "Illegal options in DEFGENERIC form: ~S." w)) 73 | (cl:let ((old-aliases (macroexpand '%aliases% env)) 74 | (function-alias (global name)) 75 | (new-lambda-list (parse-lambda-list lambda-list))) 76 | `(cl:progn 77 | (cl:defgeneric ,function-alias ,new-lambda-list 78 | ,@(loop for option in options 79 | if (cl:eq (cl:car option) :method) 80 | collect (loop for (element . body) on (cl:cdr option) 81 | until (cl:listp element) 82 | collect element into qualifiers 83 | finally 84 | (multiple-value-bind 85 | (new-lambda-list new-aliases) 86 | (parse-lambda-list element :specializers cl:t) 87 | (return 88 | `(:method ,@qualifiers ,new-lambda-list 89 | ,(expand-method-body qualifiers new-aliases old-aliases body))))) 90 | else collect option)) 91 | (import-function ,name ,function-alias ,lambda-list)))) 92 | 93 | (defmacro defmethod (&whole w &environment env name &body method-rest) 94 | (cl:let ((old-aliases (macroexpand '%aliases% env)) 95 | (function-alias (global name))) 96 | (loop for (element . body) on method-rest 97 | until (cl:listp element) 98 | collect element into qualifiers 99 | finally 100 | (multiple-value-bind 101 | (new-lambda-list new-aliases) 102 | (parse-lambda-list element :specializers cl:t) 103 | (return 104 | `(cl:progn 105 | (cl:unless (fboundp ',function-alias) 106 | (cl:error "DEFMETHOD must be preceded by a DEFGENERIC: ~S." ',w)) 107 | (cl:defmethod ,function-alias ,@qualifiers ,new-lambda-list 108 | ,(expand-method-body qualifiers new-aliases old-aliases body)) 109 | ',name)))))) 110 | 111 | (defmacro defclass (&whole w class-name superclasses &body options) 112 | (expand-defclass w class-name superclasses options)) 113 | 114 | (defmacro define-condition (&whole w class-name superclasses &body options) 115 | (expand-defclass w class-name superclasses options cl:t)) 116 | 117 | (defmacro let (bindings &body body) 118 | (loop for (var form) in bindings 119 | for alias = (copy-symbol var) 120 | collect `(,alias ,form) into new-bindings 121 | collect (cl:list var alias) into new-aliases 122 | finally (return `(cl:let ,new-bindings 123 | (with-imported-variables ,new-aliases ,@body))))) 124 | 125 | (defmacro let* (bindings &body body) 126 | (cl:if bindings 127 | `(let (,(cl:car bindings)) 128 | (let* ,(cl:cdr bindings) ,@body)) 129 | `(cl:progn ,@body))) 130 | 131 | (defmacro flet (&environment env bindings &body body) 132 | (loop for (fun lambda-list . fun-body) in bindings 133 | for alias = (copy-symbol fun) 134 | collect (multiple-value-bind 135 | (new-lambda-list new-body) 136 | (process-lambda env lambda-list fun-body) 137 | `(,alias ,new-lambda-list ,new-body)) into new-bindings 138 | collect (cl:list fun alias) into new-aliases 139 | finally (return `(cl:flet ,new-bindings 140 | (with-imported-functions ,new-aliases ,@body))))) 141 | 142 | (defmacro labels (&environment env bindings &body body) 143 | (loop with new-aliases = (loop for (fun) in bindings 144 | collect (cl:list fun (copy-symbol fun))) 145 | for (cl:nil lambda-list . fun-body) in bindings 146 | for (cl:nil alias) in new-aliases 147 | collect (multiple-value-bind 148 | (new-lambda-list new-body) 149 | (process-lambda env lambda-list fun-body) 150 | `(,alias ,new-lambda-list (with-imported-functions ,new-aliases 151 | ,new-body))) 152 | into new-bindings 153 | finally (return `(cl:labels ,new-bindings 154 | (with-imported-functions ,new-aliases 155 | ,@body))))) 156 | 157 | (defmacro block (&whole w name &body body) 158 | (unless (cl:symbolp name) 159 | (cl:error "Invalid block name ~S in ~S." name w)) 160 | (cl:let ((alias (copy-symbol name))) 161 | `(cl:block ,name 162 | (with-imported-block (,name ,alias) ,@body)))) 163 | 164 | (defmacro return-from (&whole w name form) 165 | (unless (cl:symbolp name) 166 | (cl:error "Invalid block name ~S in ~S." name w)) 167 | `(cl:return-from ,name ,form)) 168 | 169 | (defmacro catch (tag-form &body forms) 170 | `(cl:catch ,tag-form ,@forms)) 171 | 172 | (defmacro throw (tag-form result-form) 173 | `(cl:throw ,tag-form ,result-form)) 174 | 175 | (defmacro tagbody (&body body) 176 | `(cl:tagbody ,@body)) 177 | 178 | (defmacro go (tag) 179 | `(cl:go ,tag)) 180 | 181 | (defmacro unwind-protect (form &body cleanup-forms) 182 | `(cl:unwind-protect ,form ,@cleanup-forms)) 183 | 184 | (defmacro defdynamic (name &body form) 185 | (assert (cl:null (cl:cdr form))) 186 | `(cl:progn 187 | (cl:setf (symbol-value ',name) ,(cl:car form)) 188 | ',name)) 189 | 190 | (defmacro dynamic (var) 191 | `(symbol-value ',var)) 192 | 193 | (defmacro set-dynamic (form var) 194 | `(cl:setf (symbol-value ',var) ,form)) 195 | 196 | (defmacro dynamic-let (bindings &body body) 197 | (assert (cl:and (cl:listp bindings) (every #'cl:null (cl:mapcar #'cl:cddr bindings)))) 198 | `(progv 199 | ',(cl:mapcar #'cl:car bindings) 200 | (cl:list ,@(cl:mapcar #'cl:cadr bindings)) 201 | ,@body)) 202 | 203 | (defmacro function (&environment env var) 204 | (cl:cond ((cl:symbolp var) 205 | (cl:let ((alias (get-alias var '%function-aliases% env))) 206 | (cl:if alias 207 | `(cl:function ,alias) 208 | `(cl:function ,var)))) 209 | ((cl:and (cl:consp var) (cl:eq (cl:car var) 'lambda)) var) 210 | (cl:t `(cl:function ,var)))) 211 | 212 | (cl:defun symbol-function (var &optional env) 213 | (cl:symbol-function 214 | (cl:or (get-alias var '%function-aliases% env) 215 | var))) 216 | 217 | (cl:defun macro-function (var &optional env) 218 | (cl:if (cl:symbolp var) 219 | (cl:let ((alias (get-alias var '%function-aliases% env))) 220 | (cl:if alias 221 | (cl:macro-function alias) 222 | (cl:macro-function var))) 223 | (cl:error "Not a symbol: ~a" var))) 224 | 225 | (import-function functionp cl:functionp (obj)) 226 | (import-function apply cl:apply (function &rest args)) 227 | (import-function funcall cl:funcall (function &rest args)) 228 | 229 | (import-variable t cl:t) 230 | (import-variable nil cl:nil) 231 | 232 | (import-function eq cl:eq (obj1 obj2)) 233 | (import-function eql cl:eql (obj1 obj2)) 234 | 235 | (defun equal (obj1 obj2) 236 | (cl:or (cl:equal obj1 obj2) 237 | (cl:if (cl:and (cl:stringp obj1) (cl:stringp obj2)) 238 | (cl:string= obj1 obj2) 239 | (cl:equalp obj1 obj2)))) 240 | 241 | (import-function not cl:not (obj)) 242 | (import-macro and cl:and (&rest forms)) 243 | (import-macro or cl:or (&rest forms)) 244 | 245 | (defmacro quote (object) `(cl:quote ,object)) 246 | 247 | (defmacro setq (&rest forms) `(cl:setq ,@forms)) 248 | (import-macro setf cl:setf (&rest forms)) 249 | 250 | (defmacro if (test-form then-form &rest else-form) 251 | (assert (cl:or (cl:null else-form) (cl:null (cl:cdr else-form)))) 252 | `(cl:if ,test-form ,then-form ,@else-form)) 253 | 254 | (import-macro cond cl:cond (&rest forms)) 255 | 256 | (defmacro case (keyform &body clauses) 257 | `(cl:case ,keyform ,@(loop for (key . forms) in clauses 258 | if (cl:eq key 't) collect `(cl:t ,@forms) 259 | else collect `(,key ,@forms)))) 260 | 261 | (defmacro case-using (predform keyform &body clauses) 262 | (rebinding (predform keyform) 263 | `(cl:cond ,@(loop for clause in clauses 264 | if (cl:eq (cl:car clause) 't) collect clause 265 | else collect `((find ,keyform ',(cl:car clause) :test ,predform) 266 | ,@(cl:cdr clause)))))) 267 | 268 | (defmacro progn (&body forms) 269 | `(cl:progn ,@forms)) 270 | 271 | (defmacro while (test-form &body body) 272 | `(loop while ,test-form do (cl:progn ,@body))) 273 | 274 | (defmacro for (iteration-specs end-spec &body body) 275 | (cl:let ((block-name (cl:gensym)) 276 | (tag (cl:gensym)) 277 | (steps (loop for (var cl:nil . step) in iteration-specs 278 | do (assert (cl:null (cl:cdr step))) 279 | when step collect (list* var (copy-symbol var) step)))) 280 | `(cl:block ,block-name 281 | (let ,(loop for (var init) in iteration-specs 282 | collect `(,var ,init)) 283 | (cl:tagbody 284 | ,tag 285 | (when ,(cl:car end-spec) 286 | (cl:return-from ,block-name (cl:progn ,@(cl:cdr end-spec)))) 287 | (cl:progn ,@body 288 | (cl:let ,(loop for (cl:nil temp step) in steps 289 | collect `(,temp ,step)) 290 | (cl:setq ,@(loop for (var temp) in steps 291 | nconc (cl:list var temp))))) 292 | (cl:go ,tag)))))) 293 | 294 | (defun generic-function-p (object) 295 | (typep object 'generic-function)) 296 | 297 | (define-method-combination nil () 298 | ((primary () :required cl:t)) 299 | `(call-method ,(first primary) ,(rest primary))) 300 | 301 | (defgeneric create (class &rest initargs) 302 | (:method (class &rest initargs) 303 | ;; SBCL balks at dynamic extent for a symbol macro. 304 | ;; (declare (dynamic-extent initargs)) 305 | (cl:if (subtypep class (load-time-value (find-class 'condition))) 306 | (cl:apply #'make-condition class initargs) 307 | (cl:apply #'make-instance class initargs)))) 308 | 309 | (import-generic-function initialize-object initialize-instance (instance &rest args)) 310 | (import-function class-of cl:class-of (object)) 311 | (import-function instancep typep (obj class)) 312 | (import-function subclassp subtypep (class1 class2)) 313 | 314 | (defmacro class (name) `(find-class ',name)) 315 | 316 | (defmacro the (class-name form) `(cl:the ,class-name ,form)) 317 | 318 | (defmacro assure (class-name form) 319 | (rebinding (form) 320 | `(cl:progn 321 | (assert (typep ,form (find-class ',class-name)) (,form) 322 | 'type-error :datum ,form :expected-type ',class-name) 323 | ,form))) 324 | 325 | (cl:defgeneric convert-function (obj type) 326 | (:method ((obj character) (type (cl:eql '))) obj) 327 | (:method ((obj character) (type (cl:eql '))) (char-code obj)) 328 | (:method ((obj character) (type (cl:eql '))) (intern (string obj))) 329 | 330 | (:method ((obj integer) (type (cl:eql '))) (code-char obj)) 331 | (:method ((obj integer) (type (cl:eql '))) obj) 332 | (:method ((obj integer) (type (cl:eql '))) (coerce obj 'cl:float)) 333 | (:method ((obj integer) (type (cl:eql '))) (princ-to-string obj)) 334 | 335 | (:method ((obj cl:float) (type (cl:eql '))) obj) 336 | (:method ((obj cl:float) (type (cl:eql '))) (princ-to-string obj)) 337 | 338 | (:method ((obj symbol) (type (cl:eql '))) obj) 339 | (:method ((obj symbol) (type (cl:eql '))) (symbol-name obj)) 340 | 341 | (:method ((obj string) (type (cl:eql '))) (parse-integer obj)) 342 | (:method ((obj string) (type (cl:eql '))) (assure cl:float (read-from-string obj))) 343 | (:method ((obj string) (type (cl:eql '))) (intern obj)) 344 | (:method ((obj string) (type (cl:eql '))) obj) 345 | (:method ((obj string) (type (cl:eql '))) obj) 346 | (:method ((obj string) (type (cl:eql '))) (coerce obj 'cl:list)) 347 | 348 | (:method ((obj cl:vector) (type (cl:eql '))) obj) 349 | (:method ((obj cl:vector) (type (cl:eql '))) (coerce obj 'cl:list)) 350 | (:method ((obj cl:list) (type (cl:eql '))) (coerce obj 'cl:vector)) 351 | (:method ((obj cl:list) (type (cl:eql '))) obj)) 352 | 353 | (defmacro convert (obj class-name) 354 | `(convert-function ,obj ',class-name)) 355 | 356 | (import-function symbolp cl:symbolp (obj)) 357 | (import-function property get (symbol property-name &rest obj)) 358 | (defun set-property (value symbol indicator) 359 | (cl:setf (get symbol indicator) value)) 360 | (defun remove-property (symbol property-name) 361 | (prog1 (get symbol property-name) 362 | (remprop symbol property-name))) 363 | (import-function gensym cl:gensym ()) 364 | 365 | (import-function numberp cl:numberp (obj)) 366 | (defun parse-number (string) 367 | (assure number (read-from-string string))) 368 | (import-function = cl:= (x1 x2)) 369 | (import-function /= cl:/= (x1 x2)) 370 | (import-function >= cl:>= (x1 x2)) 371 | (import-function <= cl:<= (x1 x2)) 372 | (import-function > cl:> (x1 x2)) 373 | (import-function < cl:< (x1 x2)) 374 | (import-function + cl:+ (&rest args)) 375 | (import-function * cl:* (&rest args)) 376 | (import-function - cl:- (arg &rest args)) 377 | (import-function quotient cl:/ (dividend divisor &rest more-divisors)) 378 | (import-function reciprocal cl:/ (x)) 379 | (import-function max cl:max (number &rest more-numbers)) 380 | (import-function min cl:min (number &rest more-numbers)) 381 | (import-function abs cl:abs (number)) 382 | (import-function exp cl:exp (x)) 383 | (import-function log cl:log (x)) 384 | (import-function expt cl:expt (x1 x2)) 385 | (import-function sqrt cl:sqrt (x)) 386 | (import-variable *pi* pi) 387 | (import-function sin cl:sin (x)) 388 | (import-function cos cl:cos (x)) 389 | (import-function tan cl:tan (x)) 390 | (import-function atan cl:atan (x)) 391 | (import-function atan2 cl:atan (x y)) 392 | (import-function sinh cl:sinh (x)) 393 | (import-function cosh cl:cosh (x)) 394 | (import-function tanh cl:tanh (x)) 395 | (import-function atanh cl:atanh (x)) 396 | (import-variable *most-positive-float* most-positive-long-float) 397 | (import-variable *most-negative-float* most-negative-long-float) 398 | (import-function floatp cl:floatp (x)) 399 | (import-function float cl:float (x)) 400 | (import-function floor cl:floor (x)) 401 | (import-function ceiling cl:ceiling (x)) 402 | (import-function truncate cl:truncate (x)) 403 | (import-function round cl:round (x)) 404 | (import-function integerp cl:integerp (x)) 405 | (defun div (z1 z2) 406 | (values (cl:floor z1 z2))) 407 | (import-function mod cl:mod (z1 z2)) 408 | (import-function gcd cl:gcd (z1 z2)) 409 | (import-function lcm cl:lcm (z1 z2)) 410 | (import-function isqrt cl:isqrt (z)) 411 | 412 | (import-function characterp cl:characterp (obj)) 413 | (import-function char= cl:char= (char1 char2)) 414 | (import-function char/= cl:char/= (char1 char2)) 415 | (import-function char< cl:char< (char1 char2)) 416 | (import-function char> cl:char> (char1 char2)) 417 | (import-function char<= cl:char<= (char1 char2)) 418 | (import-function char>= cl:char<= (char1 char2)) 419 | 420 | (import-function consp cl:consp (obj)) 421 | (import-function cons cl:cons (obj1 obj2)) 422 | 423 | (import-function car cl:car (cons)) 424 | (import-function cdr cl:cdr (cons)) 425 | (defun set-car (object cons) 426 | (cl:setf (cl:car cons) object)) 427 | (defun set-cdr (object cons) 428 | (cl:setf (cl:cdr cons) object)) 429 | (import-function caaaar cl:caaaar (cons)) 430 | (import-function caaadr cl:caaadr (cons)) 431 | (import-function caaar cl:caaar (cons)) 432 | (import-function caadar cl:caadar (cons)) 433 | (import-function caaddr cl:caaddr (cons)) 434 | (import-function caadr cl:caadr (cons)) 435 | (import-function caar cl:caar (cons)) 436 | (import-function cadaar cl:cadaar (cons)) 437 | (import-function cadadr cl:cadadr (cons)) 438 | (import-function cadar cl:cadar (cons)) 439 | (import-function caddar cl:caddar (cons)) 440 | (import-function cadddr cl:cadddr (cons)) 441 | (import-function caddr cl:caddr (cons)) 442 | (import-function cadr cl:cadr (cons)) 443 | (import-function cdaaar cl:cdaaar (cons)) 444 | (import-function cdaadr cl:cdaadr (cons)) 445 | (import-function cdaar cl:cdaar (cons)) 446 | (import-function cdadar cl:cdadar (cons)) 447 | (import-function cdaddr cl:cdaddr (cons)) 448 | (import-function cdadr cl:cdadr (cons)) 449 | (import-function cdar cl:cdar (cons)) 450 | (import-function cddaar cl:cddaar (cons)) 451 | (import-function cddadr cl:cddadr (cons)) 452 | (import-function cddar cl:cddar (cons)) 453 | (import-function cdddar cl:cdddar (cons)) 454 | (import-function cddddr cl:cddddr (cons)) 455 | (import-function cdddr cl:cdddr (cons)) 456 | (import-function cddr cl:cddr (cons)) 457 | 458 | (import-function null cl:null (obj)) 459 | 460 | (import-function listp cl:listp (obj)) 461 | (defun create-list (i &rest initial-element) 462 | (cl:if initial-element 463 | (make-list i :initial-element (cl:car initial-element)) 464 | (make-list i))) 465 | (import-function list cl:list (&rest objects)) 466 | (import-function reverse cl:reverse (list)) 467 | (import-function nreverse cl:nreverse (list)) 468 | (import-function append cl:append (&rest lists)) 469 | (import-function member cl:member (obj list)) 470 | (import-function mapcar cl:mapcar (function list &rest more-lists)) 471 | (import-function mapc cl:mapc (function list &rest more-lists)) 472 | (import-function mapcan cl:mapcan (function list &rest more-lists)) 473 | (import-function maplist cl:maplist (function list &rest more-lists)) 474 | (import-function mapl cl:mapl (function list &rest more-lists)) 475 | (import-function mapcon cl:mapcon (function list &rest more-lists)) 476 | (import-function assoc cl:assoc (obj assoc-list)) 477 | 478 | (import-function basic-arrayp-p arrayp (obj)) 479 | (defun basic-array*-p (obj) 480 | (cl:and (arrayp obj) (cl:> (array-rank obj) 1))) 481 | (defun general-array*-p (obj) 482 | (cl:and (arrayp obj) (cl:> (array-rank obj) 1))) 483 | (defun create-array (dimensions &rest initial-element) 484 | (cl:if initial-element 485 | (make-array dimensions :initial-element (cl:car initial-element)) 486 | (make-array dimensions))) 487 | (import-function aref cl:aref (array &rest indexes)) 488 | (import-function garef cl:aref (array &rest indexes)) 489 | (defun set-aref (obj array &rest indexes) 490 | (cl:setf (cl:apply #'cl:aref array indexes) obj)) 491 | (defun set-garef (obj array &rest indexes) 492 | (cl:setf (cl:apply #'cl:aref array indexes) obj)) 493 | (import-function array-dimensions cl:array-dimensions (array)) 494 | 495 | (import-function basic-vector-p vectorp (obj)) 496 | (import-function general-vector-p vectorp (obj)) 497 | (import-function create-vector create-array (i &rest initial-element)) 498 | (import-function vector cl:vector (&rest objects)) 499 | 500 | (import-function stringp cl:stringp (obj)) 501 | (defun create-string (i &rest initial-element) 502 | (cl:if initial-element 503 | (make-string i :initial-element (cl:car initial-element)) 504 | (make-string i))) 505 | (import-function string= cl:string= (s1 s2)) 506 | (import-function string/= cl:string/= (s1 s2)) 507 | (import-function string< cl:string< (s1 s2)) 508 | (import-function string> cl:string> (s1 s2)) 509 | (import-function string>= cl:string>= (s1 s2)) 510 | (import-function string<= cl:string<= (s1 s2)) 511 | (defun char-index (char string &rest start-position) 512 | (cl:if start-position 513 | (position char string :start (cl:car start-position)) 514 | (position char string))) 515 | (defun string-index (substring string &rest start-position) 516 | (cl:if start-position 517 | (search substring string :start2 (cl:car start-position)) 518 | (search substring string))) 519 | (defun string-append (&rest strings) 520 | (cl:apply #'concatenate 'string strings)) 521 | 522 | (import-function length cl:length (sequence)) 523 | (import-function elt cl:elt (sequence z)) 524 | (defun set-elt (obj sequence z) 525 | (cl:setf (cl:elt sequence z) obj)) 526 | (import-function subseq cl:subseq (sequence z1 z2)) 527 | (import-function map-into cl:map-into (destination function &rest sequences)) 528 | 529 | (import-function streamp cl:streamp (obj)) 530 | (import-function open-stream-p cl:open-stream-p (obj)) 531 | (import-function input-stream-p cl:input-stream-p (obj)) 532 | (import-function output-stream-p cl:output-stream-p (obj)) 533 | (defun standard-input () *standard-input*) 534 | (defun standard-output () *standard-output*) 535 | (defun error-output () *error-output*) 536 | 537 | (defmacro with-standard-input (stream-form &body body) 538 | `(cl:let ((*standard-input* ,stream-form)) ,@body)) 539 | 540 | (defmacro with-standard-output (stream-form &body body) 541 | `(cl:let ((*standard-output* ,stream-form)) ,@body)) 542 | 543 | (defmacro with-error-output (stream-form &body body) 544 | `(cl:let ((*error-output* ,stream-form)) ,@body)) 545 | 546 | (cl:defun element-type (element-class) 547 | (cl:if element-class 548 | (cl:let ((element-type (cl:car element-class))) 549 | (cl:if (cl:numberp element-type) 550 | `(unsigned-byte ,element-type) 551 | element-type)) 552 | 'character)) 553 | 554 | (defun open-input-file (filename &rest element-class) 555 | (open filename :direction :input :element-type (element-type element-class))) 556 | 557 | (defun open-output-file (filename &rest element-class) 558 | (open filename :direction :output :element-type (element-type element-class))) 559 | 560 | (defun open-io-file (filename &rest element-class) 561 | (open filename :direction :io :element-type (element-type element-class))) 562 | 563 | (defmacro with-open-input-file (spec &body body) 564 | (destructuring-bind (name filename &rest element-class) spec 565 | (cl:let ((alias (copy-symbol name))) 566 | `(with-open-file ,(cl:if element-class 567 | `(,alias ,filename 568 | :direction :input 569 | :element-type ,(cl:car element-class)) 570 | `(,alias ,filename :direction :input)) 571 | (with-imported-variables ((,name ,alias)) 572 | ,@body))))) 573 | 574 | (defmacro with-open-output-file (spec &body body) 575 | (destructuring-bind (name filename &rest element-class) spec 576 | (cl:let ((alias (copy-symbol name))) 577 | `(with-open-file ,(cl:if element-class 578 | `(,alias ,filename 579 | :direction :output 580 | :element-type ,(cl:car element-class)) 581 | `(,alias ,filename :direction :output)) 582 | (with-imported-variables ((,name ,alias)) 583 | ,@body))))) 584 | 585 | (defmacro with-open-io-file (spec &body body) 586 | (destructuring-bind (name filename &rest element-class) spec 587 | (cl:let ((alias (copy-symbol name))) 588 | `(with-open-file ,(cl:if element-class 589 | `(,alias ,filename 590 | :direction :io 591 | :element-type ,(cl:car element-class)) 592 | `(,alias ,filename :direction :io)) 593 | (with-imported-variables ((,name ,alias)) 594 | ,@body))))) 595 | 596 | (import-function close cl:close (stream)) 597 | (import-function finish-output cl:finish-output (stream)) 598 | 599 | (import-function create-string-input-stream make-string-input-stream (string)) 600 | (import-function create-string-output-stream make-string-output-stream ()) 601 | (import-function get-output-stream-string cl:get-output-stream-string (stream)) 602 | 603 | (import-function read cl:read (&rest args)) 604 | (import-function read-char cl:read-char (&rest args)) 605 | (defun preview-char (&rest args) 606 | (cl:apply #'peek-char cl:nil args)) 607 | (import-function read-line cl:read-line (&rest args)) 608 | (import-function stream-ready-p listen (input-stream)) 609 | 610 | (import-function format cl:format (output-stream format-string &rest args)) 611 | (defun format-char (output-stream char) 612 | (write-char char output-stream)) 613 | (defun format-float (output-stream float) 614 | (cl:format output-stream "~G" float)) 615 | (import-function format-fresh-line fresh-line (output-stream)) 616 | (defun format-integer (output-stream integer radix) 617 | (write integer :stream output-stream :base radix)) 618 | (defun format-object (output-stream obj escape-p) 619 | (write obj :stream output-stream :escape escape-p)) 620 | (defun format-tab (output-stream column) 621 | (pprint-tab :line column 1 output-stream)) 622 | 623 | (import-function read-byte cl:read-byte (input-stream &rest args)) 624 | (import-function write-byte cl:write-byte (z output-stream)) 625 | 626 | (import-function probe-file cl:probe-file (filename)) 627 | (import-function file-position cl:file-position (stream)) 628 | (import-function set-file-position cl:file-position (stream z)) 629 | (defun file-length (filename element-class) 630 | (with-open-input-file (stream filename element-class) (cl:file-length stream))) 631 | 632 | (import-function error cl:error (error-string &rest args)) 633 | 634 | (defvar *condition-continuables* '()) 635 | 636 | (cl:defun -signal-condition- (condition continuable) 637 | (cl:if continuable 638 | (cl:let* ((continuable 639 | (cl:if (cl:eq continuable 'cl:t) 640 | "Continue with no special action." 641 | continuable)) 642 | (*condition-continuables* 643 | (acons condition continuable 644 | *condition-continuables*))) 645 | (restart-case (signal condition) 646 | (continue (value) 647 | :report (cl:lambda (stream) (cl:format stream continuable)) 648 | value))) 649 | (signal condition))) 650 | 651 | (import-function signal-condition -signal-condition- (condition continuable)) 652 | 653 | (defun cerror (continue-string error-string &rest args) 654 | (-signal-condition- 655 | (make-instance ' 656 | :format-string error-string 657 | :format-arguments args) 658 | (cl:apply #'cl:format cl:nil continue-string args))) 659 | 660 | (import-macro ignore-errors cl:ignore-errors (&rest forms)) 661 | 662 | (defun condition-continuable (condition) 663 | (cl:cdr (cl:assoc condition *condition-continuables*))) 664 | 665 | (defun continue-condition (condition &rest value) 666 | (cl:let ((restart (find-restart 'continue condition))) 667 | (cl:apply #'invoke-restart restart value))) 668 | 669 | (defmacro with-handler (handler &body body) 670 | `(handler-bind ((cl:t ,handler)) ,@body)) 671 | 672 | (import-function arithmetic-error-operation cl:arithmetic-error-operation (error)) 673 | (import-function arithmetic-error-operands cl:arithmetic-error-operands (error)) 674 | (import-function domain-error-object type-error-datum (error)) 675 | (import-function domain-error-expected-class type-error-expected-type (error)) 676 | (import-function simple-error-format-string simple-condition-format-control (error)) 677 | (import-function simple-error-format-arguments simple-condition-format-arguments (error)) 678 | (import-function stream-error-stream cl:stream-error-stream (error)) 679 | (import-function undefined-entity-name cell-error-name (error)) 680 | 681 | (import-function identity cl:identity (obj)) 682 | 683 | (import-function get-universal-time cl:get-universal-time ()) 684 | (import-function get-internal-run-time cl:get-internal-run-time ()) 685 | (import-function get-internal-real-time cl:get-internal-real-time ()) 686 | (defun internal-time-units-per-second () cl:internal-time-units-per-second) 687 | --------------------------------------------------------------------------------