├── .gitignore ├── LICENSE ├── README.md ├── examples ├── sicp-constraint-propagators.lisp ├── sicp-digital-circuits.lisp ├── sicp-metacircular-evaluator.lisp └── sicp-register-machine.lisp ├── schemeish.asd └── src ├── alists.lisp ├── and-let.lisp ├── arities.lisp ├── bundle.lisp ├── code-transformer.lisp ├── continuations.lisp ├── cut.lisp ├── define-struct.lisp ├── define.lisp ├── documentation.lisp ├── expand-stream-collect.lisp ├── expand-struct.lisp ├── expose.lisp ├── for-macros.lisp ├── function-body.lisp ├── function-combinators.lisp ├── group.lisp ├── guard.lisp ├── hash-tables.lisp ├── lambda-list.lisp ├── lambda.lisp ├── letrec.lisp ├── lexical-body-definitions.lisp ├── lexical-body.lisp ├── lists.lisp ├── logic.lisp ├── markup-renderer.lisp ├── markup.lisp ├── named-let.lisp ├── numbers.lisp ├── output.lisp ├── package-utils.lisp ├── package.lisp ├── procedures.lisp ├── promises.lisp ├── queue.lisp ├── schemeish-package-definition.lisp ├── scm.lisp ├── set.lisp ├── sets.lisp ├── splitf.lisp ├── stream-collect.lisp ├── streams.lisp ├── strings.lisp ├── struct.lisp ├── symbols.lisp ├── syntax.lisp ├── trees.lisp ├── unique-symbol.lisp └── vectors.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | *.fasl 2 | unused/ 3 | src/continuations-notes.lisp 4 | src/continuations-old.lisp 5 | *.~undo-tree~ 6 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2021 Christopher Hebert 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, 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 DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /examples/sicp-constraint-propagators.lisp: -------------------------------------------------------------------------------- 1 | (cl:defpackage #:sicp-constraint-propagators 2 | (:use :schemeish)) 3 | 4 | (in-package #:sicp-constraint-propagators) 5 | 6 | (install-syntax!) 7 | 8 | (define (inform-about-value constraint) 9 | [constraint :i-have-a-value]) 10 | (define (inform-about-no-value constraint) 11 | [constraint :i-lost-my-value]) 12 | 13 | (define (for-each-except exception f list) 14 | (for-each f (remove exception list))) 15 | 16 | (define connector? (make-bundle-predicate :connector)) 17 | (define (make-connector (value nil) (informant nil) (constraints '())) 18 | (define (has-value?) informant) 19 | (define (get-value) value) 20 | (define (set-value! new-value setter) 21 | (cond 22 | ((not (has-value?)) 23 | (setq value new-value) 24 | (setq informant setter) 25 | (for-each-except setter 26 | 'inform-about-value 27 | constraints)) 28 | ((not (= value new-value)) 29 | (error "Contradiction: ~S" (list value new-value))) 30 | (t :ignored))) 31 | (define (forget-value! retractor) 32 | (cond 33 | ((eq? informant retractor) 34 | (setq informant nil) 35 | (for-each-except retractor 36 | 'inform-about-no-value 37 | constraints)) 38 | (t :ignored))) 39 | (define (connect new-constraint) 40 | (when (not (member new-constraint constraints)) 41 | (push new-constraint constraints)) 42 | (when (has-value?) 43 | (inform-about-value new-constraint))) 44 | 45 | (bundle #'connector? 46 | has-value? 47 | get-value 48 | set-value! 49 | forget-value! 50 | connect)) 51 | 52 | (define (has-value? connector) 53 | [[connector :has-value?]]) 54 | (define (get-value connector) 55 | [[connector :get-value]]) 56 | (define (set-value! connector new-value informant) 57 | [[connector :set-value!] new-value informant]) 58 | (define (forget-value! connector retractor) 59 | [[connector :forget-value!] retractor]) 60 | (define (connect connector new-constraint) 61 | [[connector :connect] new-constraint]) 62 | 63 | (define (adder a1 a2 sum) 64 | (define (process-new-value) 65 | (cond ((and (has-value? a1) (has-value? a2)) 66 | (set-value! sum 67 | (+ (get-value a1) (get-value a2)) 68 | me)) 69 | ((and (has-value? a1) (has-value? sum)) 70 | (set-value! a2 71 | (- (get-value sum) (get-value a1)) 72 | me)) 73 | ((and (has-value? a2) (has-value? sum)) 74 | (set-value! a1 75 | (- (get-value sum) (get-value a2)) 76 | me)))) 77 | (define (process-forget-value) 78 | (forget-value! sum me) 79 | (forget-value! a1 me) 80 | (forget-value! a2 me) 81 | (process-new-value)) 82 | (define (me request) 83 | (cond ((eq? request :I-have-a-value) 84 | (process-new-value)) 85 | ((eq? request :I-lost-my-value) 86 | (process-forget-value)) 87 | (t 88 | (error "Unknown request -- ADDER ~S" request)))) 89 | (connect a1 me) 90 | (connect a2 me) 91 | (connect sum me) 92 | me) 93 | 94 | (define (multiplier m1 m2 product) 95 | (define (process-new-value) 96 | (cond ((or (and (has-value? m1) (= (get-value m1) 0)) 97 | (and (has-value? m2) (= (get-value m2) 0))) 98 | (set-value! product 0 me)) 99 | ((and (has-value? m1) (has-value? m2)) 100 | (set-value! product 101 | (* (get-value m1) (get-value m2)) 102 | me)) 103 | ((and (has-value? product) (has-value? m1)) 104 | (set-value! m2 105 | (/ (get-value product) (get-value m1)) 106 | me)) 107 | ((and (has-value? product) (has-value? m2)) 108 | (set-value! m1 109 | (/ (get-value product) (get-value m2)) 110 | me)))) 111 | (define (process-forget-value) 112 | (forget-value! product me) 113 | (forget-value! m1 me) 114 | (forget-value! m2 me) 115 | (process-new-value)) 116 | (define (me request) 117 | (cond ((eq? request :I-have-a-value) 118 | (process-new-value)) 119 | ((eq? request :I-lost-my-value) 120 | (process-forget-value)) 121 | (t 122 | (error "Unknown request -- MULTIPLIER ~S" request)))) 123 | (connect m1 me) 124 | (connect m2 me) 125 | (connect product me) 126 | me) 127 | 128 | (define (squarer a b) 129 | (define (process-new-value) 130 | (if (has-value? b) 131 | (if (< (get-value b) 0) 132 | (error "square less than 0 -- SQUARER ~S" (get-value b)) 133 | (set-value! a (sqrt (get-value b)) me)) 134 | (set-value! b (sqr (get-value a)) me))) 135 | (define (process-forget-value) 136 | (forget-value! a me) 137 | (forget-value! b me)) 138 | (define (me request) 139 | (cond ((eq? request :I-have-a-value) 140 | (process-new-value)) 141 | ((eq? request :I-lost-my-value) 142 | (process-forget-value)) 143 | (t (error "Unknown request -- SQUARER ~S" request)))) 144 | (connect a me) 145 | (connect b me) 146 | me) 147 | 148 | 149 | (define (constant value connector) 150 | (define (me request) 151 | (error "Unknown request -- CONSTANT ~S" request)) 152 | (connect connector me) 153 | (set-value! connector value me) 154 | me) 155 | 156 | 157 | (define (probe name connector) 158 | (define (print-probe value) 159 | (format t "~&Probe: ~A = ~S" name value)) 160 | (define (process-new-value) 161 | (print-probe (get-value connector))) 162 | (define (process-forget-value) 163 | (print-probe "?")) 164 | (define (me request) 165 | (cond ((eq? request :I-have-a-value) 166 | (process-new-value)) 167 | ((eq? request :I-lost-my-value) 168 | (process-forget-value)) 169 | (t 170 | (error "Unknown request -- PROBE ~S" request)))) 171 | (connect connector me) 172 | me) 173 | 174 | (define (averager a b average) 175 | (let ((numer (make-connector)) 176 | (denom (make-connector))) 177 | (adder a b numer) 178 | (constant 1/2 denom) 179 | (multiplier numer denom average) 180 | :ok)) 181 | 182 | (define (celsius-fahrenheit-converter c f) 183 | (let ((u (make-connector)) 184 | (v (make-connector)) 185 | (w (make-connector)) 186 | (x (make-connector)) 187 | (y (make-connector))) 188 | (multiplier c w u) 189 | (multiplier v x u) 190 | (adder v y f) 191 | (constant 9 w) 192 | (constant 5 x) 193 | (constant 32 y) 194 | 'ok)) 195 | 196 | (defparameter *c* (make-connector)) 197 | (defparameter *f* (make-connector)) 198 | (celsius-fahrenheit-converter *c* *f*) 199 | ;; => OK 200 | 201 | (probe "Celsius temp" *c*) 202 | (probe "Fahrenheit temp" *f*) 203 | 204 | (set-value! *C* 25 'user) 205 | #|| 206 | Output: 207 | Probe: Celsius temp = 25 208 | Probe: Fahrenheit temp = 77 209 | ||# 210 | ;; (set-value! *f* 212 'user) 211 | ;; error: Contradiction: (77 212) 212 | 213 | (forget-value! *c* 'user) 214 | #|| 215 | Output: 216 | Probe: Celsius temp = "?" 217 | Probe: Fahrenheit temp = "?" 218 | ||# 219 | 220 | (set-value! *f* 212 'user) 221 | #|| 222 | Output: 223 | Probe: Fahrenheit temp = 212 224 | Probe: Celsius temp = 100 225 | ||# 226 | 227 | (defparameter *sqrt* (make-connector)) 228 | (defparameter *square* (make-connector)) 229 | (probe "sqrt" *sqrt*) 230 | (probe "square" *square*) 231 | 232 | (squarer *sqrt* *square*) 233 | 234 | (set-value! *square* 16 'user) 235 | #|| 236 | Output: 237 | Probe: sqrt = 4.0 238 | Probe: square = 16 239 | ||# 240 | ;; => NIL 241 | (forget-value! *square* 'user) 242 | #|| 243 | Output: 244 | Probe: sqrt = "?" 245 | Probe: square = "?" 246 | ||# 247 | ;; => NIL 248 | (set-value! *sqrt* 3 'user) 249 | #|| 250 | Output: 251 | Probe: square = 9 252 | Probe: sqrt = 3 253 | ||# 254 | ;; => NIL 255 | 256 | (define (c+ x y) 257 | (let ((z (make-connector))) 258 | (adder x y z) 259 | z)) 260 | 261 | (define (c* x y) 262 | (let ((z (make-connector))) 263 | (multiplier x y z) 264 | z)) 265 | 266 | (define (cv value) 267 | (let ((c (make-connector))) 268 | (constant value c) 269 | c)) 270 | 271 | (define (c- x y) 272 | (c+ x (c* y (cv -1)))) 273 | 274 | (define (c/ x y) 275 | (let ((z (make-connector))) 276 | (multiplier z y x) 277 | z)) 278 | 279 | (define (fahrenheit-celsius-converter f) 280 | (c* (c- f (cv 32)) (c/ (cv 5) (cv 9)))) 281 | 282 | (defparameter *f* (make-connector)) 283 | (defparameter *c* (fahrenheit-celsius-converter *f*)) 284 | 285 | (probe "Celsius temp" *c*) 286 | (probe "Fahrenheit temp" *f*) 287 | 288 | (set-value! *C* 25 'user) 289 | #|| 290 | Output: 291 | Probe: Celsius temp = 25 292 | Probe: Fahrenheit temp = 77 293 | ||# 294 | ;; => NIL 295 | 296 | (uninstall-syntax!) 297 | -------------------------------------------------------------------------------- /examples/sicp-digital-circuits.lisp: -------------------------------------------------------------------------------- 1 | (cl:defpackage #:sicp-digital-circuits 2 | (:use :schemeish)) 3 | 4 | (in-package #:sicp-digital-circuits) 5 | 6 | (install-syntax!) 7 | 8 | (defvar *the-agenda*) 9 | 10 | (define (make-agenda (current-time 0) (segments ())) 11 | (define (make-time-segment time queue) 12 | (cons time queue)) 13 | (define (segment-time s) (car s)) 14 | (define (segment-queue s) (cdr s)) 15 | 16 | (define (empty?) (null? segments)) 17 | 18 | (define (first-item) 19 | (cond ((empty?) (error "Trying to get the first item from an empty agenda.")) 20 | (t (let ((segment (first segments))) 21 | (setq current-time (segment-time segment)) 22 | (queue-front (segment-queue segment)))))) 23 | 24 | (define (remove-first-item!) 25 | (cond ((empty?) (error "Trying to remove the first item from an empty agenda.")) 26 | (t (let ((q (segment-queue (first segments)))) 27 | (queue-delete! q) 28 | (when (queue-empty? q) 29 | (setq segments (rest segments))))))) 30 | 31 | (define (add! time action) 32 | (define (belongs-before? segments) 33 | (or (null? segments) 34 | (< time (segment-time (first segments))))) 35 | (define (make-new-time-segment time action) 36 | (let ((q (make-queue))) 37 | (queue-insert! q action) 38 | (make-time-segment time q))) 39 | (define (add-to-segments! segments) 40 | (let ((first (first segments)) 41 | (rest (rest segments))) 42 | (cond 43 | ((= time (segment-time first)) 44 | (queue-insert! (segment-queue first) action)) 45 | ((belongs-before? rest) 46 | (set-cdr! segments 47 | (cons (make-new-time-segment time action) rest))) 48 | (t (add-to-segments! rest))))) 49 | (cond 50 | ((belongs-before? segments) 51 | (setq segments (cons (make-new-time-segment time action) segments))) 52 | (t (add-to-segments! segments)))) 53 | 54 | (define (get-current-time) current-time) 55 | 56 | (bundle nil 57 | empty? first-item remove-first-item! add! get-current-time)) 58 | 59 | (define (empty-agenda? a) [[a :empty?]]) 60 | (define (first-agenda-item a) [[a :first-item]]) 61 | (define (current-time a) [[a :get-current-time]]) 62 | (define (remove-first-agenda-item! a) [[a :remove-first-item!]]) 63 | (define (add-to-agenda! time action a) [[a :add!] time action]) 64 | 65 | (define (after-delay delay action) 66 | (add-to-agenda! (+ delay (current-time *the-agenda*)) 67 | action 68 | *the-agenda*)) 69 | 70 | (define (propagate) 71 | (cond 72 | ((empty-agenda? *the-agenda*) 73 | :done) 74 | (t 75 | (let ((first-item (first-agenda-item *the-agenda*))) 76 | [first-item] 77 | (remove-first-agenda-item! *the-agenda*) 78 | (propagate))))) 79 | 80 | (define (call-each procedures) 81 | (for-each (lambda (proc) [proc]) procedures)) 82 | 83 | (define wire? (make-bundle-predicate :wire)) 84 | (define (make-wire (signal-value 0) (action-procedures '())) 85 | (define (set-signal! new-value) 86 | (if (not (= signal-value new-value)) 87 | (progn 88 | (setq signal-value new-value) 89 | (call-each action-procedures)) 90 | :done)) 91 | (define (accept-action-procedure! proc) 92 | (setq action-procedures (cons proc action-procedures)) 93 | [proc]) 94 | (define (get-signal) signal-value) 95 | (bundle nil set-signal! accept-action-procedure! get-signal)) 96 | 97 | (define (get-signal wire) [[wire :get-signal]]) 98 | (define (set-signal! wire new-value) [[wire :set-signal!] new-value]) 99 | (define (add-action! wire action-procedure) 100 | [[wire :accept-action-procedure!] action-procedure]) 101 | 102 | (let ((wire (make-wire)) 103 | (result nil)) 104 | (assert (= 0 (get-signal wire))) 105 | (add-action! wire (lambda () (setq result (get-signal wire)))) 106 | (set-signal! wire 1) 107 | (assert (= result 1))) 108 | 109 | (define (signal->bool signal) 110 | (cond ((= 0 signal) nil) 111 | ((= 1 signal) t) 112 | (t (error "bad signal ~s" signal)))) 113 | (define (bool->signal bool) (if bool 1 0)) 114 | 115 | (define (logical procedure) 116 | (lambda signal-args 117 | (bool->signal [procedure (map 'signal->bool signal-args)]))) 118 | 119 | (define (logical-not signal) (bool->signal (not (signal->bool signal)))) 120 | (define (logical-and s1 s2) [(logical (lcurry 'for-all 'identity)) s1 s2]) 121 | (define (logical-or s1 s2) [(logical (lcurry 'there-exists 'identity)) s1 s2]) 122 | 123 | (assert (= 1 (logical-not 0))) 124 | (assert (= 0 (logical-not 1))) 125 | (assert (= 0 (logical-and 0 1))) 126 | (assert (= 1 (logical-and 1 1))) 127 | (assert (= 1 (logical-or 0 1))) 128 | (assert (= 0 (logical-or 0 0))) 129 | 130 | 131 | (defvar *inverter-delay*) 132 | (defvar *and-gate-delay*) 133 | (defvar *or-gate-delay*) 134 | 135 | (define (inverter input output) 136 | (define (invert-input) 137 | (let ((new-value (logical-not (get-signal input)))) 138 | (after-delay *inverter-delay* 139 | (lambda () (set-signal! output new-value))))) 140 | (add-action! input invert-input) 141 | :ok) 142 | 143 | (define (and-gate a1 a2 output) 144 | (define (and-action-procedure) 145 | (let ((new-value (logical-and (get-signal a1) 146 | (get-signal a2)))) 147 | (after-delay *and-gate-delay* 148 | (lambda () (set-signal! output new-value))))) 149 | (add-action! a1 and-action-procedure) 150 | (add-action! a2 and-action-procedure) 151 | :ok) 152 | 153 | (define (or-gate o1 o2 output) 154 | (define (action-procedure) 155 | (let ((new-value (logical-or (get-signal o1) 156 | (get-signal o2)))) 157 | (after-delay *or-gate-delay* 158 | (lambda () (set-signal! output new-value))))) 159 | (add-action! o1 action-procedure) 160 | (add-action! o2 action-procedure) 161 | :ok) 162 | 163 | (define (half-adder a b sum carry) 164 | (let ((d (make-wire)) (e (make-wire))) 165 | (or-gate a b d) 166 | (and-gate a b carry) 167 | (inverter carry e) 168 | (and-gate d e sum) 169 | :ok)) 170 | 171 | (define (full-adder a b carry-in sum carry-out) 172 | (let ((partial-sum (make-wire)) 173 | (carry1 (make-wire)) 174 | (carry2 (make-wire))) 175 | (half-adder b carry-in partial-sum carry1) 176 | (half-adder a partial-sum sum carry2) 177 | (or-gate carry1 carry2 carry-out))) 178 | 179 | (define (probe name wire) 180 | (add-action! 181 | wire 182 | (lambda () 183 | (format t "~%~S ~S New-value = ~S" 184 | name (current-time *the-agenda*) (get-signal wire))))) 185 | 186 | (defparameter *inverter-delay* 2) 187 | (defparameter *and-gate-delay* 3) 188 | (defparameter *or-gate-delay* 5) 189 | 190 | (defparameter *the-agenda* (make-agenda)) 191 | 192 | (defparameter *input-1* (make-wire)) 193 | (defparameter *input-2* (make-wire)) 194 | (defparameter *sum* (make-wire)) 195 | (defparameter *carry* (make-wire)) 196 | 197 | (probe :sum *sum*) 198 | ;; :SUM 0 New-value = 0 199 | (probe :carry *carry*) 200 | ;; :CARRY 0 New-value = 0 201 | 202 | (half-adder *input-1* *input-2* *sum* *carry*) 203 | (set-signal! *input-1* 1) 204 | (propagate) 205 | ;; :SUM 8 New-value = 1 206 | 207 | (set-signal! *input-2* 1) 208 | (propagate) 209 | ;; :CARRY 11 New-value = 1 210 | ;; :SUM 16 New-value = 0 211 | 212 | 213 | (defparameter *the-agenda* (make-agenda)) 214 | 215 | (defparameter *input-1* (make-wire)) 216 | (defparameter *input-2* (make-wire)) 217 | (defparameter *carry-in* (make-wire)) 218 | (defparameter *sum* (make-wire)) 219 | (defparameter *carry-out* (make-wire)) 220 | 221 | (probe :sum *sum*) 222 | ;; :SUM 0 New-value = 0 223 | (probe :carry-out *carry-out*) 224 | ;; :CARRY-OUT 0 New-value = 0 225 | 226 | (full-adder *input-1* *input-2* *carry-in* *sum* *carry-out*) 227 | ;; => :OK 228 | 229 | (set-signal! *input-1* 1) 230 | (set-signal! *input-2* 0) 231 | (set-signal! *carry-in* 1) 232 | 233 | (propagate) 234 | ;; :SUM 8 New-value = 1 235 | ;; :CARRY-OUT 16 New-value = 1 236 | ;; :SUM 16 New-value = 0 237 | 238 | (uninstall-syntax!) 239 | -------------------------------------------------------------------------------- /schemeish.asd: -------------------------------------------------------------------------------- 1 | ;;;; schemeish.asd 2 | 3 | (asdf:defsystem #:schemeish 4 | :description "Provide Scheme style syntax/macros/functions in a Common Lisp environment." 5 | :author "Christopher Hebert " 6 | :license "MIT" 7 | :version "0.0.1" 8 | :serial t 9 | :pathname "src/" 10 | :depends-on (:trivial-arguments :trivial-cltl2) 11 | :components ((:file "package") 12 | ;; SCHEMEISH.INTERNALS 13 | (:file "named-let") 14 | (:file "markup") 15 | (:file "documentation") 16 | (:file "for-macros") 17 | (:file "unique-symbol") 18 | (:file "guard") 19 | (:file "syntax") 20 | (:file "splitf") 21 | (:file "lambda-list") 22 | (:file "lexical-body") 23 | (:file "expose") 24 | (:file "function-body") 25 | (:file "lexical-body-definitions") 26 | (:file "define") 27 | 28 | ;; SCHEMEISH.BACKEND 29 | (:file "lambda") 30 | (:file "symbols") 31 | (:file "numbers") 32 | (:file "logic") 33 | (:file "lists") 34 | (:file "letrec") 35 | (:file "procedures") 36 | (:file "alists") 37 | (:file "sets") 38 | (:file "strings") 39 | (:file "trees") 40 | (:file "output") 41 | (:file "set") 42 | (:file "promises") 43 | (:file "streams") 44 | (:file "arities") 45 | (:file "group") 46 | (:file "hash-tables") 47 | (:file "vectors") 48 | (:file "expand-struct") 49 | (:file "define-struct") 50 | (:file "code-transformer") 51 | (:file "scm") 52 | (:file "cut") 53 | (:file "markup-renderer") 54 | (:file "and-let") 55 | (:file "expand-stream-collect") 56 | (:file "stream-collect") 57 | (:file "bundle") 58 | (:file "queue") 59 | (:file "package-utils") 60 | (:file "schemeish-package-definition"))) 61 | -------------------------------------------------------------------------------- /src/alists.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:schemeish.backend) 2 | 3 | (install-syntax!) 4 | 5 | ;;; Alist 6 | 7 | (export 8 | (define (alist-ref alist key (failure-result)) 9 | "Rerturns the value associated with key in alist, else the failure-result." 10 | (let ((pair (assoc key alist :test #'equal?))) 11 | (if (pair? pair) 12 | (cdr pair) 13 | failure-result)))) 14 | (export 15 | (define (alist-remove alist key) 16 | "Returns an alist with key removed." 17 | (remove key alist :test #'equal? :key #'car))) 18 | (export 19 | (define (alist-set alist key value) 20 | "Returns an alist with key set to value." 21 | (acons key value (alist-remove alist key)))) 22 | 23 | 24 | (export 25 | (define (alist-union alist new-alist) 26 | (foldl (lambda (pair alist) 27 | (alist-set alist (car pair) (cdr pair))) 28 | alist new-alist))) 29 | 30 | (export 31 | (define (alist-update alist key updater (failure-result)) 32 | "Applies updater to the value associated with key and updates the result in alist. 33 | Applies updater to failure-result if key is not present." 34 | (alist-set alist key [updater (alist-ref alist key failure-result)]))) 35 | 36 | (export 37 | (define (alist-map alist proc) 38 | "Alist with proc applied to all values of alist." 39 | (map (lambda (binding) [proc (car binding) (cdr binding)]) alist))) 40 | 41 | (export 42 | (define (alist-for-each alist proc) 43 | "Proc applied to all values of alist." 44 | (for-each (lambda (binding) [proc (car binding) (cdr binding)]) alist))) 45 | 46 | (export 47 | (define (alist-keys alist) 48 | "A list of all keys in alist." 49 | (alist-map alist (lambda (key value) (declare (ignore value)) key)))) 50 | (export 51 | (define (alist-values alist) 52 | "A list of all of the values in alist." 53 | (alist-map alist (lambda (key value) (declare (ignore key)) value)))) 54 | 55 | (export 56 | (define (alist-has-key? alist key) 57 | "T if the key is present in alist" 58 | (let ((no-key (gensym))) 59 | (not (eq? no-key (alist-ref alist key no-key)))))) 60 | 61 | (export 62 | (define (alist-set* alist . keys-and-values) 63 | "Update all of the values in alist with pairs of key value ..." 64 | (let rec ((keys-and-values keys-and-values) 65 | (alist alist)) 66 | (cond 67 | ((empty? keys-and-values) alist) 68 | ((empty? (rest keys-and-values)) (error "badly formed arguments.")) 69 | (t (let ((key (first keys-and-values)) 70 | (value (second keys-and-values))) 71 | (rec 72 | (drop keys-and-values 2) 73 | (alist-set alist key value)))))))) 74 | 75 | (export 76 | (define (alist . keys-and-values) 77 | "Constructs an alist from pairs of key value ..." 78 | (nreverse (apply #'alist-set* () keys-and-values)))) 79 | 80 | (uninstall-syntax!) -------------------------------------------------------------------------------- /src/and-let.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:schemeish.backend) 2 | 3 | (install-syntax!) 4 | 5 | (for-macros 6 | (define (and-let*-form clauses body) 7 | (cond 8 | ((empty? clauses) `(progn ,@body)) 9 | (t 10 | (let ((clause (first clauses))) 11 | (cond 12 | ((list? clause) 13 | (cond 14 | ((null? (rest clause)) 15 | `(and ,(first clause) ,(and-let*-form (rest clauses) body))) 16 | (t 17 | `(let ((,(first clause) ,(second clause))) 18 | (and ,(first clause) ,(and-let*-form (rest clauses) body)))))) 19 | (t (error "invalid clause in and-let*: ~S" clause)))))))) 20 | 21 | (defmacro and-let* ((&rest clauses) &body body) 22 | "Evaluate each clause from first to last until one is false. If all are true, evaluate body. 23 | Each clause is one of: identifier, (expression), or (identifier expression). 24 | If the clause is (identifier expression) it creates a binding for the rest of the clauses and the body. 25 | Example (and-let* ((list (compute-list)) 26 | ((pair? list)) 27 | (item (car list)) 28 | ((integer? item))) 29 | (sqrt item))" 30 | (and-let*-form clauses body)) 31 | (export 'and-let*) 32 | 33 | (uninstall-syntax!) 34 | -------------------------------------------------------------------------------- /src/arities.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:schemeish.backend) 2 | 3 | (install-syntax!) 4 | 5 | ;; TODO: Replace these with map-ordinary-lambda-list 6 | (defparameter *lambda-list-keywords* 7 | '(&optional &rest &key &allow-other-keys &aux)) 8 | (define (parse-lambda-list-arguments argument-list) 9 | (define (parse-arg-sublist args result result-key arg-proc (parsed-args)) 10 | (cond ((or (empty? args) 11 | (member (first args) *lambda-list-keywords*)) 12 | ;; Reached the end of this sublist. 13 | ;; Add parsed-args to the result alist and continue parsing from parse-args 14 | (parse-args args (alist-set result result-key (nreverse parsed-args)))) 15 | (t 16 | ;; Add this argument to the parsed-arg-list and continue parsing the sublist. 17 | (parse-arg-sublist (rest args) 18 | result 19 | result-key 20 | arg-proc 21 | (cons [arg-proc (first args)] 22 | parsed-args))))) 23 | 24 | (define (parse-required-args args result) 25 | (parse-arg-sublist args result :required #'identity)) 26 | 27 | (define (parse-optional-args args result) 28 | (parse-arg-sublist args result :optional (lambda (arg) (first (flatten arg))))) 29 | 30 | (define (parse-key-args args result) 31 | (parse-arg-sublist args result :key (lambda (arg) (first (flatten arg))))) 32 | 33 | (define (parse-args args (result)) 34 | (cond 35 | ;; No more arguments. Return the result. 36 | ((empty? args) (nreverse result)) 37 | (t 38 | (let ((arg (first args))) 39 | (cond 40 | ((eq? arg '&optional) (parse-optional-args (rest args) result)) 41 | ((eq? arg '&rest) (parse-args (drop args 2) (alist-set result :rest (second args)))) 42 | ((eq? arg '&key) (parse-key-args (rest args) result)) 43 | ((eq? arg '&allow-other-keys) (parse-args (rest args) (alist-set result :allow-other-keys? t))) 44 | ((eq? arg '&aux) (parse-args () result)) 45 | (t (parse-required-args args result))))))) 46 | (parse-args argument-list)) 47 | 48 | (export 49 | (define (procedure-arguments procedure) 50 | "Returns the procedure's argument list in the form of an alist with the following keys (in order): 51 | (:required . required-arguments) 52 | (:optional . optional-arguments) 53 | (:rest . rest-arg-name) 54 | (:key . keyword-arguments) 55 | (:allow-other-keys? . t/nil)" 56 | (parse-lambda-list-arguments (arg:arglist procedure)))) 57 | 58 | (assert (equal? (procedure-arguments (cl:lambda (a b c) a b c)) 59 | '((:REQUIRED A B C)))) 60 | 61 | (assert (equal? (procedure-arguments (cl:lambda (a b c &optional d (e 1) (f 2 f-provided?)) 62 | a b c d e f f-provided?)) 63 | '((:REQUIRED A B C) (:OPTIONAL D E F)))) 64 | 65 | (assert (equal? (procedure-arguments (cl:lambda (a b c &optional d (e 1) (f 2 f-provided?) &rest rest) 66 | a b c d e f f-provided? rest)) 67 | '((:REQUIRED A B C) (:OPTIONAL D E F) (:REST . REST)))) 68 | 69 | ;; Disable tests that involve &optional and &key arguments 70 | 71 | #+nil 72 | (assert (equal? (procedure-arguments (cl:lambda (a b c &optional d (e 1) (f 2 f-provided?) &rest rest &key g (h 1) (i 2 i-provided?)) 73 | a b c d e f f-provided? rest g h i i-provided?)) 74 | '((:REQUIRED A B C) (:OPTIONAL D E F) (:REST . REST) (:KEY G H I)))) 75 | 76 | #+nil 77 | (assert (equal? (procedure-arguments (cl:lambda (a b c &optional d (e 1) (f 2 f-provided?) &rest rest &key g (h 1) (i 2 i-provided?) &allow-other-keys) 78 | a b c d e f f-provided? rest g h i i-provided?)) 79 | '((:REQUIRED A B C) (:OPTIONAL D E F) (:REST . REST) (:KEY G H I) 80 | (:ALLOW-OTHER-KEYS? . T)))) 81 | 82 | #+nil 83 | (assert (equal? 84 | (procedure-arguments (cl:lambda (a b c &optional d (e 1) (f 2 f-provided?) &rest rest &key g (h 1) (i 2 i-provided?) &allow-other-keys &aux j (k 1)) 85 | a b c d e f f-provided? rest g h i i-provided? j k)) 86 | '((:REQUIRED A B C) (:OPTIONAL D E F) (:REST . REST) (:KEY G H I) 87 | (:ALLOW-OTHER-KEYS? . T)))) 88 | 89 | 90 | [(lcurry (lambda (:k1) k1) :k1) 'keywords-have-arity=2-or-0] 91 | ;; => KEYWORDS-HAVE-ARITY=2-OR-0 92 | 93 | (null? (ignore-errors [(lcurry (lambda (:k1) k1) :k1)])) 94 | ;; => T 95 | 96 | [(lambda (:k1) k1)] 97 | ;; => NIL 98 | 99 | [(lambda ((optional)) optional)] 100 | ;; => NIL 101 | [(lambda ((optional)) optional) :optionals-have-arity=1-or-0] 102 | ;; => :OPTIONALS-HAVE-ARITY=1-OR-0 103 | 104 | [(cl:lambda (&key &allow-other-keys) :allow-other-keys-have-infinite-even-arity) 1 2 3 4 5 6 7 8] 105 | ;; Disable tests that pass improper arities 106 | 107 | #+nil 108 | (null? (ignore-errors [(cl:lambda (&key &allow-other-keys) :allow-other-keys-have-infinite-even-arity) 1 2 3 4 5 6 7 8 9])) 109 | ;; => T 110 | 111 | [(cl:lambda (&rest rest) rest) :rest :has :infinite :arity] 112 | ;; => (:REST :HAS :INFINITE :ARITY) 113 | 114 | [(cl:lambda (&rest rest &key &allow-other-keys) rest) :rest :and :allow-other-keys :have :infitite :arity] 115 | ;; => (:REST :AND :ALLOW-OTHER-KEYS :HAVE :INFITITE :ARITY) 116 | #+nil 117 | (null? (ignore-errors [(cl:lambda (&rest rest &key &allow-other-keys) rest) :even :arity :only!])) 118 | ;; => T 119 | 120 | (export 121 | (define (procedure-arguments-required-arguments arguments) 122 | (alist-ref arguments :required ()))) 123 | (export 124 | (define (procedure-arguments-optional-arguments arguments) 125 | (alist-ref arguments :optional ()))) 126 | (export 127 | (define (procedure-arguments-key-arguments arguments) 128 | (alist-ref arguments :key ()))) 129 | (export 130 | (define (procedure-arguments-rest-argument arguments) 131 | (alist-ref arguments :rest ()))) 132 | (export 133 | (define (procedure-arguments-allow-other-keys? arguments) 134 | (alist-ref arguments :allow-other-keys? ()))) 135 | 136 | (export 137 | (define (procedure-arity procedure) 138 | "Returns an arity of the form '(n1 n2 n3 ...) where n is one of: 139 | an integer representing an exact number of arguments 140 | a pair '(:* . X) representing an indefinite number of arguments following x number of arguments, 141 | or a pair '(:** . X) representing an indefinite number of key-argument pairs following x number of arguments. 142 | 143 | Examples: 144 | (procedure-arity (cl:lambda (fixed1 fixed2 &optional opt1 opt2 &rest rest &key key1 key2) ...)) ;; => '(2 3 4 6 (:* . 8)) 145 | (procedure-arity (cl:lambda (&rest rest &key k1 k2 &allow-other-keys) ...)) ;; => '(2 (:** . 4)) 146 | " 147 | (define arguments (procedure-arguments procedure)) 148 | (define required-arity (list (length (procedure-arguments-required-arguments arguments)))) 149 | 150 | (define (extend-arity base-arity arity-proc) 151 | (cons [arity-proc (first base-arity)] base-arity)) 152 | 153 | (define (arity-extended-by-optional-like base-arity num arg-arity-n) 154 | (cond ((= 0 num) base-arity) 155 | (t (arity-extended-by-optional-like 156 | (extend-arity base-arity (lambda (n) (+ arg-arity-n n))) 157 | (1- num) 158 | arg-arity-n)))) 159 | 160 | (define (arity-extended-by-optionals base-arity) 161 | (arity-extended-by-optional-like base-arity 162 | (length (procedure-arguments-optional-arguments arguments)) 163 | 1)) 164 | (define (arity-extended-by-keys base-arity) 165 | (arity-extended-by-optional-like base-arity 166 | (length (procedure-arguments-key-arguments arguments)) 167 | 2)) 168 | 169 | (define (arity-extended-by-indefinite base-arity rest? allow-other-keys?) 170 | (cond 171 | (allow-other-keys? (cons (cons :** (first base-arity)) (rest base-arity))) 172 | (rest? (cons (cons :* (first base-arity)) (rest base-arity))) 173 | (t base-arity))) 174 | 175 | (define (arity-finished base-arity) 176 | (nreverse base-arity)) 177 | 178 | (arity-finished 179 | (arity-extended-by-indefinite 180 | (arity-extended-by-keys (arity-extended-by-optionals required-arity)) 181 | (not (null? (procedure-arguments-rest-argument arguments))) 182 | (procedure-arguments-allow-other-keys? arguments))))) 183 | 184 | (assert (equal? (procedure-arity (cl:lambda ())) 185 | '(0))) 186 | (assert (equal? (procedure-arity (cl:lambda (a b c) a b c)) 187 | '(3))) 188 | (assert (equal? (procedure-arity (cl:lambda (a b &optional c d) a b c d)) 189 | '(2 3 4))) 190 | (assert (equal? (procedure-arity (cl:lambda (a b &optional c d &rest rest) a b c d rest)) 191 | '(2 3 (:* . 4)))) 192 | 193 | #+nil 194 | (assert (equal? (procedure-arity (cl:lambda (a b &optional c d &rest rest &key e f) a b c d e f rest)) 195 | '(2 3 4 6 (:* . 8)))) 196 | #+nil 197 | (assert (equal? (procedure-arity (cl:lambda (a b &optional c d &rest rest &key e f &allow-other-keys) a b c d e f rest)) 198 | '(2 3 4 6 (:** . 8)))) 199 | (assert (equal? (procedure-arity (cl:lambda (&rest rest) rest)) 200 | '((:* . 0)))) 201 | (assert (equal? (procedure-arity (cl:lambda (&key &allow-other-keys))) 202 | '((:** . 0)))) 203 | 204 | (export 205 | (define (has-specific-arity? arity-list fixed-arity-n) 206 | "Returns true if an arity-list (retrieved from procedure-arity) has the specific fixed arity." 207 | (assert (or (zero? fixed-arity-n) (positive? fixed-arity-n))) 208 | (cond ((empty? arity-list) nil) 209 | (t 210 | (let ((arity (first arity-list))) 211 | (cond 212 | ((and (number? arity) (= fixed-arity-n arity)) t) 213 | ((pair? arity) 214 | (let ((type (car arity)) 215 | (value (cdr arity))) 216 | (cond 217 | ((eq? type :*) (<= value fixed-arity-n)) 218 | ((eq? type :**) (and (<= value fixed-arity-n) 219 | (eq? (even? fixed-arity-n) (even? value))))))) 220 | (t (has-specific-arity? (rest arity-list) fixed-arity-n)))))))) 221 | 222 | (assert (has-specific-arity? '(2 3 4) 3)) 223 | (assert (not (has-specific-arity? '(2 3 4) 5))) 224 | (assert (has-specific-arity? '(2 3 (:* . 4)) 5)) 225 | (assert (not (has-specific-arity? '(2 3 (:** . 4)) 5))) 226 | (assert (has-specific-arity? '(2 3 (:** . 4)) 6)) 227 | 228 | ;; TODO: Arity-table 229 | ;; TODO: Restrict arity when creating higher order functions. COMPOSE, etc. 230 | ;; TODO: Generics 231 | 232 | (uninstall-syntax!) 233 | -------------------------------------------------------------------------------- /src/bundle.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:schemeish.backend) 2 | 3 | (install-syntax!) 4 | 5 | (defvar *get-bundle-type-predicate* (gensym)) 6 | (defvar *get-bundle-predicate-symbol* (gensym)) 7 | 8 | (define (make-bundle-predicate name) 9 | "Returns a predicate which, only evaluates to true 10 | when given a bundle with this type-predicate" 11 | (define (dispatch arg) 12 | (cond 13 | ((eq? *get-bundle-predicate-symbol* arg) name) 14 | ((procedure? arg) 15 | (eq? dispatch [arg *get-bundle-type-predicate*])) 16 | (t nil))) 17 | dispatch) 18 | (export 'make-bundle-predicate) 19 | 20 | (export 21 | (define (bundle-predicate-symbol predicate) 22 | "Returns the debug symbol associated with predicate." 23 | [predicate *get-bundle-predicate-symbol*])) 24 | 25 | (defvar *name?* (make-bundle-predicate :bundle)) 26 | (assert [*name?* (lambda (arg) 27 | (cond 28 | ((eq *get-bundle-type-predicate* arg) *name?*)))]) 29 | 30 | (defvar *get-bundle-permissions* (gensym "GET-BUNDLE-PERMISSIONS")) 31 | 32 | (define (get-fn-identifier? fn-identifier) 33 | (and (eql (first fn-identifier) :get) 34 | (symbol? (second fn-identifier)) 35 | (empty? (rest (rest fn-identifier))))) 36 | (define (set-fn-identifier? fn-identifier) 37 | (and (eql (first fn-identifier) :set!) 38 | (symbol? (second fn-identifier)) 39 | (or (empty? (rest (rest fn-identifier))) 40 | (and (symbol? (third fn-identifier)) 41 | (empty? (rest (rest (rest fn-identifier)))))))) 42 | 43 | (define (set-fn-identifier-setter-keyword fn-identifier) 44 | (make-keyword (make-symbol (or (and-let* ((name (third fn-identifier))) (symbol->string name)) 45 | (concatenate 'string "SET-" (symbol->string (second fn-identifier)) "!"))))) 46 | 47 | (define (fn-identifier->permission-name fn-identifier) 48 | (cond ((symbol? fn-identifier) (make-keyword fn-identifier)) 49 | ((get-fn-identifier? fn-identifier) (make-keyword (second fn-identifier))) 50 | ((set-fn-identifier? fn-identifier) 51 | (make-keyword (set-fn-identifier-setter-keyword fn-identifier))))) 52 | 53 | ;; TODO: switch to a case statement 54 | (define (bundle-fn-identifier->permission-form arg-name fn-identifier) 55 | (let* ((permission-name (fn-identifier->permission-name fn-identifier)) 56 | (test-permission-form `(eq ,permission-name ,arg-name))) 57 | (cond ((symbol? fn-identifier) 58 | `(,test-permission-form ,fn-identifier)) 59 | ((get-fn-identifier? fn-identifier) 60 | `(,test-permission-form (lambda () ,(second fn-identifier)))) 61 | ((set-fn-identifier? fn-identifier) 62 | (let ((value-name (unique-symbol 'value))) 63 | `(,test-permission-form 64 | (lambda (,value-name) (set! ,(second fn-identifier) ,value-name)))))))) 65 | 66 | (assert (equal? (bundle-fn-identifier->permission-form 'arg 'fn-name) 67 | '((EQ :FN-NAME ARG) FN-NAME))) 68 | (assert (equal? (bundle-fn-identifier->permission-form 'arg '(:get variable-name)) 69 | '((EQ :VARIABLE-NAME ARG) 70 | (LAMBDA NIL 71 | VARIABLE-NAME)))) 72 | #+nil 73 | (assert (equal? (with-readable-symbols 74 | (bundle-fn-identifier->permission-form 'arg '(:set! variable-name))) 75 | '((EQ :SET-VARIABLE-NAME! ARG) 76 | (LAMBDA (VALUE) 77 | (SET! VARIABLE-NAME VALUE))))) 78 | #+nil 79 | (assert (equal? (with-readable-symbols 80 | (bundle-fn-identifier->permission-form 'arg '(:set! variable-name setter-name!))) 81 | '((EQ :setter-name! ARG) 82 | (LAMBDA (VALUE) 83 | (SET! VARIABLE-NAME VALUE))))) 84 | 85 | (for-macros 86 | (defvar *bundles* (make-hash-table :weakness :key)) 87 | 88 | (define (register-bundle! bundle) 89 | (setf (gethash bundle *bundles*) t) 90 | bundle)) 91 | 92 | (export 93 | (define (bundle? bundle) 94 | (gethash bundle *bundles*))) 95 | 96 | (defmacro bundle (type-predicate &rest fn-identifiers) 97 | "Create a bundle of permissions for closure objects. 98 | A bundle is a function (bundle-proc msg) => permission, where each permission 99 | is meant to be a locally defined function described by fn-identifiers. 100 | Each fn-identifier is one of: 101 | fn-name => a symbolic name which maps to a function value. 102 | Produces a :fn-name permission. 103 | (:get variable-name) => variable-name is a symbolic name which maps to a value. 104 | Produces a :variable-name permission which returns a function of zero arguments. 105 | (:set! variable-name ) => variable-name is a symbolic name which maps to a value. 106 | Produces a :setter-name permission which returns a function of one argument. 107 | If setter-name defaults to :set-variable-name! if not provided. 108 | 109 | Type-predicate is nil or a predicate created by make-bundle-predicate. 110 | Example: 111 | (defparameter *point?* (make-bundle-predicate :point)) 112 | (define (make-point x y) 113 | (define (get-x) x) 114 | (define (get-y) y) 115 | (define (set-x! new-x) (setq x new-x)) 116 | (define (set-y! new-y) (setq y new-y)) 117 | 118 | (bundle *point?* get-x get-y set-x! set-y!)) 119 | 120 | (let ((point (make-point 3 4))) 121 | [point :get-x] ;; => closure of 0 arguments 122 | (assert (= 3 [[point :get-x]])) 123 | [point :set-x!] ;; => closure of 1 argument 124 | [[point :set-x!] 32] 125 | (assert (= 32 [[point :get-x]])) 126 | (assert [*point?* point]) 127 | (bundle-permissions bundle) ; => '(:get-x :get-y :set-x! :set-y!))" 128 | (let* ((arg-name (unique-symbol 'arg)) 129 | (permission-forms (map (lcurry #'bundle-fn-identifier->permission-form arg-name) fn-identifiers)) 130 | (permission-names (map #'fn-identifier->permission-name fn-identifiers))) 131 | (assert (every #'identity permission-forms)) 132 | `(register-bundle! 133 | (lambda (,arg-name) 134 | (cond 135 | ((eq *get-bundle-type-predicate* ,arg-name) 136 | ,(cond 137 | ((null? type-predicate) '(constantly nil)) 138 | ((symbolp type-predicate) `(function ,type-predicate)) 139 | (t type-predicate))) 140 | ((eq *get-bundle-permissions* ,arg-name) ',permission-names) 141 | ;; TODO: switch to a case statement 142 | ,@permission-forms 143 | (t (error "Unrecognized permission ~S for bundle. Expected one of: ~S" 144 | ,arg-name ',permission-names))))))) 145 | (export 'bundle) 146 | 147 | (defvar *bundle-print-object-table* (make-hash-table :weakness :key)) 148 | 149 | (export 150 | (define (define-bundle-print-object bundle print-object-proc) 151 | "Defines the print-object-proc for the given bundle. [print-object-proc stream] will be called 152 | when print-object is called on the bundle." 153 | (setf (gethash bundle *bundle-print-object-table*) print-object-proc) 154 | bundle)) 155 | (export 156 | (define (undefine-bundle-print-object bundle) 157 | "Removes the print-object-proc for the given bundle." 158 | (remhash bundle *bundle-print-object-table*) 159 | bundle)) 160 | (define (bundle-print-object-proc bundle) 161 | (gethash bundle *bundle-print-object-table*)) 162 | 163 | (export 164 | (define (bundle-documentation bundle) 165 | "Generates documentation for bundle and all of its permissions." 166 | (with-output-to-string (s) 167 | (format s "~%A bundle of type ~S with permissions:" (bundle-predicate-symbol [bundle *get-bundle-type-predicate*])) 168 | (for-each (lambda (permission) 169 | (let ((fn [bundle permission])) 170 | (format s "~& ~S: ~A" (cons (list 'bundle permission) (arg:arglist fn)) (documentation fn 'function)))) 171 | (bundle-permissions bundle))))) 172 | 173 | (export 174 | (define (bundle-permissions bundle) 175 | "Return a list of permissions to the bundle." 176 | [bundle *get-bundle-permissions*])) 177 | 178 | (define point? (make-bundle-predicate :point)) 179 | (define (make-bundle-point x y) 180 | (define (get-x) "x-coord" x) 181 | (define (get-y) "y-coord" y) 182 | (define (set-x! new-x) "set x-coord to new-x" (setq x new-x)) 183 | (define (set-y! new-y) "set y-coord to new-y" (setq y new-y)) 184 | 185 | (bundle #'point? get-x get-y set-x! set-y!)) 186 | 187 | (defmethod print-object :around ((object function) stream) 188 | (if (bundle? object) 189 | (let ((proc (bundle-print-object-proc object))) 190 | (if proc 191 | [proc stream] 192 | (print-unreadable-object (object stream :identity t) 193 | (format stream "BUNDLE ~S" (bundle-predicate-symbol [object *get-bundle-type-predicate*]))))) 194 | (call-next-method))) 195 | 196 | (make-bundle-point 3 4) 197 | 198 | (bundle-documentation (make-bundle-point 3 4)) 199 | "(MAKE-BUNDLE-POINT 3 4) 200 | A bundle of type :POINT with permissions: 201 | ((BUNDLE :GET-X)): x-coord 202 | ((BUNDLE :GET-Y)): y-coord 203 | ((BUNDLE :SET-X!) NEW-X): set x-coord to new-x 204 | ((BUNDLE :SET-Y!) NEW-Y): set y-coord to new-y" 205 | 206 | (let ((point (make-bundle-point 3 4))) 207 | (assert (bundle? point)) 208 | (assert (= 3 [[point :get-x]])) 209 | [[point :set-x!] 32] 210 | (assert (= 32 [[point :get-x]])) 211 | (assert (point? point))) 212 | #+nil 213 | (sb-introspect:function-lambda-list [(make-bundle-point 3 4) :set-x!]) 214 | ;; => (NEW-X) 215 | 216 | 217 | (uninstall-syntax!) 218 | -------------------------------------------------------------------------------- /src/code-transformer.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:schemeish.backend) 2 | 3 | (install-syntax!) 4 | 5 | (export-definition 6 | (define-struct transformer 7 | (transform-special-form-table 8 | transform-proper-list 9 | transform-dotted-list 10 | transform-cyclic-list 11 | transform-atom) 12 | :documentation 13 | "A set of functions to transform expressions. 14 | Transform-special-form-table is a hash table of SYMBOL -> TRANSFORM 15 | where [transform transformer expr environment] => new-expr. 16 | The remaining fields are also transforms.")) 17 | 18 | (export-definition 19 | (define (macro-function-application? expr environment) 20 | "True if, in the given lexical environment, expr is a macro-function application." 21 | (and (pair? expr) 22 | (symbol? (first expr)) 23 | (macro-function (first expr) environment)))) 24 | 25 | (export-definition 26 | (define (transform-expression transformer expression (environment)) 27 | "Returns an expression that has been recursively transformed using TRANSFORMER 28 | in the given lexical environment. 29 | Transform-expression first tests to see if expression is a special-form in the transformer's transform-special-form-table. 30 | If it is not a special-form, it is then macroexpanded in the given environment. 31 | If the form is a non-null proper-list (elements...), it is transformed using transformer's transform-proper-list. 32 | If the form is a dotted-list (elements... . final-element), it is transformed using the transformers's transform-dotted-list. 33 | If the form is a cyclic-list (#1#=(elements...) . #1), it is transformed using the transformer's transform-cyclic-list. 34 | Otherwise, the form is treated as an atom and transformed using the transformer's transform-atom." 35 | (define transform-special-form 36 | (when (pair? expression) 37 | (hash-ref (transformer-transform-special-form-table transformer) (first expression) nil))) 38 | (cond 39 | (transform-special-form [transform-special-form transformer expression environment]) 40 | ((macro-function-application? expression environment) 41 | (transform-expression transformer (macroexpand-1 expression environment) environment)) 42 | ((pair? expression) 43 | (ecase (list-type expression) 44 | (:proper [(transformer-transform-proper-list transformer) transformer expression environment]) 45 | (:cyclic [(transformer-transform-cyclic-list transformer) transformer expression environment]) 46 | (:dotted [(transformer-transform-dotted-list transformer) transformer expression environment]))) 47 | (t [(transformer-transform-atom transformer) transformer expression environment])))) 48 | 49 | (for-macros 50 | (defvar *transformer-table* (make-hash-table)) 51 | (export 52 | (define (register-transformer transformer-name transformer) 53 | (hash-set! *transformer-table* transformer-name transformer))) 54 | (define (registered-transformer name) 55 | (hash-ref *transformer-table* name))) 56 | 57 | (export-definition 58 | (for-macros 59 | (defvar *lexical-context* ()))) 60 | (export-definition 61 | (defmacro transform-in-lexical-environment (transformer-name expression lexical-context &environment environment) 62 | "Applies transformer to expression in environment. 63 | *LEXICAL-CONTEXT* will be bound to the given lexical-context for the duration of the transformation." 64 | (let ((*lexical-context* lexical-context)) 65 | (transform-expression (registered-transformer transformer-name) expression environment)))) 66 | 67 | (export-definition 68 | (define (transform transformer-name expression) 69 | "Returns a form that when evaluated, will transform the given expression 70 | in the current *LEXICAL-CONTEXT*." 71 | `(transform-in-lexical-environment ,transformer-name ,expression ,*lexical-context*))) 72 | 73 | (export-definition 74 | (define (declare? form) 75 | "True if form is (CL:DECLARE ...)" 76 | (and (pair? form) (eq? (first form) 'cl:declare)))) 77 | 78 | (export-definition 79 | (define (body-declarations body) 80 | "Return the initial DECLARE forms in body." 81 | (takef body #'declare?))) 82 | (export-definition 83 | (define (body-forms body) 84 | "Return the forms of body without the initial DECLARE forms." 85 | (dropf body #'declare?))) 86 | 87 | (export-definition 88 | (define (function-body-declarations body) 89 | "Return the initial [documentation] declarations... in body 90 | as (documentation declarations...)" 91 | (if (and (string? (first body)) (not (empty? (rest body)))) 92 | (cons (first body) (body-declarations (rest body))) 93 | (body-declarations body)))) 94 | (export-definition 95 | (define (function-body-forms body) 96 | "Return the forms of body with the initial [documentation] declarations... 97 | removed." 98 | (if (and (string? (first body)) (not (empty? (rest body)))) 99 | (body-forms (rest body)) 100 | (body-forms body)))) 101 | 102 | ;; Special form parsers: all assume that the given expr is well-formed. 103 | (define (quote-expr expr) (second expr)) 104 | (define (function-name expr) (second expr)) 105 | (define (progn-forms expr) (rest expr)) 106 | 107 | (define (lambda-parameters expr) (second expr)) 108 | (define (lambda-body expr) (cddr expr)) 109 | (define (lambda-body-declarations expr) (body-declarations (lambda-body expr))) 110 | (define (lambda-body-forms expr) (body-forms (lambda-body expr))) 111 | 112 | (define (let-bindings expr) (second expr)) 113 | (define (let-body expr) (cddr expr)) 114 | (define (let-body-declarations expr) (body-declarations (let-body expr))) 115 | (define (let-body-forms expr) (body-forms (let-body expr))) 116 | (define (let-binding-name expr) 117 | (if (pair? expr) 118 | (first expr) 119 | expr)) 120 | (define (let-binding-value expr) 121 | (if (pair? expr) 122 | (second expr) 123 | nil)) 124 | 125 | (define (let*-bindings expr) (let-bindings expr)) 126 | (define (let*-body expr) (let-body expr)) 127 | (define (let*-body-declarations expr) (body-declarations (let*-body expr))) 128 | (define (let*-body-forms expr) (body-forms (let*-body expr))) 129 | 130 | (define (block-name expr) (second expr)) 131 | (define (block-body expr) (cddr expr)) 132 | 133 | (define (return-from-name expr) (second expr)) 134 | (define (return-from-value expr) 135 | (or (and (= (length expr) 3) (third expr)) 136 | nil)) 137 | 138 | (define (flet-bindings expr) (second expr)) 139 | (define (flet-body expr) (cddr expr)) 140 | (define (flet-body-declarations expr) (body-declarations (flet-body expr))) 141 | (define (flet-body-forms expr) (body-forms (flet-body expr))) 142 | 143 | (define (labels-bindings expr) (second expr)) 144 | (define (labels-body expr) (cddr expr)) 145 | (define (labels-body-declarations expr) (body-declarations (labels-body expr))) 146 | (define (labels-body-forms expr) (body-forms (labels-body expr))) 147 | 148 | (define (function-binding-name expr) (first expr)) 149 | (define (function-binding-parameters expr) (second expr)) 150 | (define (function-binding-body expr) (cddr expr)) 151 | (define (function-binding-body-declarations expr) (function-body-declarations (function-binding-body expr))) 152 | (define (function-binding-body-forms expr) (function-body-forms (function-binding-body expr))) 153 | 154 | (define (macrolet-bindings expr) (second expr)) 155 | (define (macrolet-body expr) (cddr expr)) 156 | (define (macrolet-body-declarations expr) (body-declarations (macrolet-body expr))) 157 | (define (macrolet-body-forms expr) (body-forms (macrolet-body expr))) 158 | 159 | (define (symbol-macrolet-bindings expr) (second expr)) 160 | (define (symbol-macrolet-body expr) (cddr expr)) 161 | (define (symbol-macrolet-body-declarations expr) (body-declarations (symbol-macrolet-body expr))) 162 | (define (symbol-macrolet-body-forms expr) (body-forms (symbol-macrolet-body expr))) 163 | 164 | (define (eval-when-situations expr) (second expr)) 165 | (define (eval-when-forms expr) (cddr expr)) 166 | 167 | (define (setq-pairs expr) 168 | (define (recurse expr pairs) 169 | (if (empty? expr) 170 | pairs 171 | (recurse (cddr expr) (cons (list (first expr) (second expr)) pairs)))) 172 | (nreverse (recurse (rest expr) ()))) 173 | 174 | (define (if-test expr) (second expr)) 175 | (define (if-then expr) (third expr)) 176 | (define (if-else expr) (fourth expr)) 177 | 178 | (define (locally-body expr) (cdr expr)) 179 | (define (locally-body-declarations expr) (body-declarations (locally-body expr))) 180 | (define (locally-body-forms expr) (body-forms (locally-body expr))) 181 | 182 | (define (tagbody-tags-and-statements expr) (cdr expr)) 183 | (define (go-tag expr) (second expr)) 184 | 185 | (define (the-value-type expr) (second expr)) 186 | (define (the-form expr) (third expr)) 187 | 188 | (define (multiple-value-prog1-values-form expr) (second expr)) 189 | (define (multiple-value-prog1-forms expr) (cddr expr)) 190 | 191 | (define (multiple-value-call-function expr) (second expr)) 192 | (define (multiple-value-call-arguments expr) (cddr expr)) 193 | 194 | (define (load-time-value-form expr) (second expr)) 195 | (define (load-time-value-read-only-p expr) (third expr)) 196 | 197 | (define (catch-tag expr) (second expr)) 198 | (define (catch-forms expr) (cddr expr)) 199 | 200 | (define (throw-tag expr) (second expr)) 201 | (define (throw-result expr) (third expr)) 202 | 203 | (define (unwind-protect-protected expr) (second expr)) 204 | (define (unwind-protect-cleanup expr) (cddr expr)) 205 | 206 | (define (parse-tagbody tags-and-statements) 207 | "Return (untagged-statements . (tag . statements)...)." 208 | (define (tag? tag-or-statement) 209 | (or (symbol? tag-or-statement) 210 | (integerp tag-or-statement))) 211 | (define (statement? tag-or-statement) 212 | (not (tag? tag-or-statement))) 213 | 214 | (define untagged-statements (takef tags-and-statements statement?)) 215 | (define tagged-statements (dropf tags-and-statements statement?)) 216 | 217 | (define (tagged-forms-iter tags-and-statements tagged-forms) 218 | (define (parse-next-tagged-form) 219 | (define tag (first tags-and-statements)) 220 | (define statements-and-tagged-statements (rest tags-and-statements)) 221 | (define statements (takef statements-and-tagged-statements statement?)) 222 | (define rest-tags-and-statements (dropf statements-and-tagged-statements statement?)) 223 | 224 | (tagged-forms-iter rest-tags-and-statements (cons (cons tag statements) tagged-forms))) 225 | 226 | (cond 227 | ((empty? tags-and-statements) tagged-forms) 228 | (t (parse-next-tagged-form)))) 229 | 230 | (define tagged-forms 231 | (nreverse (tagged-forms-iter tagged-statements ()))) 232 | 233 | (cons untagged-statements tagged-forms)) 234 | 235 | (uninstall-syntax!) 236 | -------------------------------------------------------------------------------- /src/cut.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:schemeish.backend) 2 | 3 | (install-syntax!) 4 | 5 | (for-macros 6 | (define (cut-form cut-spec id eval-once?) 7 | (define (lambda-form arg-spec apply-form bindings) 8 | "Construct the lambda form." 9 | (let ((form `(lambda ,arg-spec ,apply-form))) 10 | (if bindings 11 | `(let* ,bindings ,form) 12 | form))) 13 | 14 | (define (placeholder? argument) 15 | "Argument matches id" 16 | (eq? argument id)) 17 | (define (make-argument-name num-args) 18 | "unique symbol of the form ARG where n is the 0-based index." 19 | (unique-symbol (string-append "ARG" (number->string num-args)))) 20 | (define (make-binding-name num-bindings) 21 | "unique symbol of the form BINDING where n is the 0-based index." 22 | (unique-symbol (string-append "BINDING" (number->string num-bindings)))) 23 | (define (make-rest-argument-name) 24 | "unique symbol of the form REST-ARG" 25 | (unique-symbol :rest-arg)) 26 | 27 | (define (process-argument spec arg-spec apply-form num-args bindings) 28 | "Spec is of the form: (provided-argument . ...)" 29 | (cond 30 | (eval-once? 31 | (let ((binding-name (make-binding-name (length bindings)))) 32 | (process-spec (rest spec) 33 | arg-spec 34 | (cons binding-name apply-form) 35 | num-args 36 | (cons (list binding-name (first spec)) bindings)))) 37 | (t (process-spec (rest spec) 38 | arg-spec 39 | (cons (first spec) apply-form) 40 | num-args 41 | bindings)))) 42 | (define (process-placeholder spec arg-spec apply-form num-args bindings) 43 | "Spec is of the form: (? . ...)" 44 | (let ((argument-name (make-argument-name num-args))) 45 | (process-spec (rest spec) 46 | (cons argument-name arg-spec) 47 | (cons argument-name apply-form) 48 | (1+ num-args) 49 | bindings))) 50 | 51 | (define (process-end-of-proper-list arg-spec apply-form bindings) 52 | "Spec is the empty list" 53 | (lambda-form (nreverse arg-spec) 54 | (nreverse (cons () apply-form)) 55 | (nreverse bindings))) 56 | 57 | (define (process-rest-placeholder arg-spec apply-form bindings) 58 | "Spec is the rest placeholder: e.g the ? in (list 1 2 . ?)" 59 | (let ((argument-name (make-rest-argument-name))) 60 | (lambda-form (append (nreverse arg-spec) argument-name) 61 | (nreverse (cons argument-name apply-form)) 62 | (nreverse bindings)))) 63 | 64 | (define (process-rest-argument spec arg-spec apply-form bindings) 65 | "Spec is a rest argument: e.g the '(3 4) in (list 1 2 . '(3 4))" 66 | (cond 67 | (eval-once? 68 | (let ((binding-name (unique-symbol :rest-binding))) 69 | (lambda-form (nreverse arg-spec) 70 | (append (nreverse apply-form) binding-name) 71 | (nreverse (cons (list binding-name spec) bindings))))) 72 | (t (lambda-form (nreverse arg-spec) 73 | (append (nreverse apply-form) spec) 74 | (nreverse bindings))))) 75 | 76 | (define (process-spec spec arg-spec apply-form num-args bindings) 77 | "Process a spec." 78 | (cond 79 | ;; spec is a list starting with a placeholder: (? . ...) 80 | ((and (pair? spec) (placeholder? (first spec))) 81 | (process-placeholder spec arg-spec apply-form num-args bindings)) 82 | ;; spec is a list starting with a provided argument: (value . ...) 83 | ((pair? spec) 84 | (process-argument spec arg-spec apply-form num-args bindings)) 85 | ;; spec is empty list 86 | ((null? spec) (process-end-of-proper-list arg-spec apply-form bindings)) 87 | ;; spec is a placeholder at the end of a dotted list 88 | ((placeholder? spec) (process-rest-placeholder arg-spec apply-form bindings)) 89 | ;; spec is a rest argument 90 | (t (error "Expected NIL or placeholder ~S in dotted cut-spec ~S: got ~S" id cut-spec spec)))) 91 | 92 | (define (initial-apply-form) 93 | "initial apply form is (apply #'fn) but reversed." 94 | (nreverse (list 'apply `(function ,(first cut-spec))))) 95 | 96 | (unless (not (pair? cut-spec)) 97 | (process-spec (rest cut-spec) 98 | () 99 | (initial-apply-form) 100 | 0 101 | ())))) 102 | 103 | (assert (equal? (with-readable-symbols 104 | (cut-form '(list) '? nil)) 105 | '(LAMBDA NIL 106 | (APPLY #'LIST ())))) 107 | (assert (equal? (with-readable-symbols 108 | (cut-form '() '? nil)) 109 | '())) 110 | #+nil 111 | (assert (equal? (with-readable-symbols 112 | (cut-form '(list 1 ? 3 ? . ?) '? nil)) 113 | '(LAMBDA (ARG0 ARG1 . rest-arg) 114 | (APPLY #'LIST 1 ARG0 3 ARG1 REST-ARG)))) 115 | (assert (not (ignore-errors (with-readable-symbols 116 | (cut-form '(list ? 3 . 4) '? nil))))) 117 | 118 | #+nil 119 | (assert (equal? (with-readable-symbols 120 | (cut-form '(list 1 ? 3 . ?) '? t)) 121 | '(LET* ((BINDING0 1) (BINDING1 3)) 122 | (LAMBDA (ARG0 . REST-ARG) 123 | (APPLY #'LIST BINDING0 ARG0 BINDING1 REST-ARG))))) 124 | 125 | 126 | (defmacro cut ((&rest cut-spec) &key (placeholder-id '_) (eval-once? t)) 127 | "Creates a 'curried' function using cut-spec and placeholder-id. 128 | Examples: 129 | [(cut (list 1 2 _ _)) 3 4] => (1 2 3 4) 130 | [(cut (+ 5 . _)) 1 2 3] => 11 131 | [(cut [(compose (cut (* 2 _)) (cut (+ 2 _ _))) 3 ?]) 3] => 16 132 | 133 | If eval-once? is true, provided arguments will be evaluated once when the function is created." 134 | (cut-form cut-spec placeholder-id eval-once?)) 135 | (export 'cut) 136 | 137 | (assert (equal? [(cut (list 1 _ 3 . _)) 2 4 5 6] 138 | '(1 2 3 4 5 6))) 139 | 140 | (uninstall-syntax!) 141 | -------------------------------------------------------------------------------- /src/define-struct.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:schemeish.backend) 2 | 3 | (install-syntax!) 4 | 5 | (defmacro define-struct (type-name (&rest field-specs) &rest struct-options) 6 | "A structure is a record object with a CLOS class type, 7 | automatically generated constructor of the form (MAKE- field-args...) 8 | field accessors of the form (- struct-arg), 9 | and a type predicate of the form (? datum). 10 | It takes takes the form 11 | (define-struct type-name (field-specs...) struct-options...) 12 | Where a field-spec is either FIELD-NAME or (FIELD-NAME :MUTABLE) 13 | and a struct-option is one of: 14 | :mutable 15 | :opaque 16 | :super super-struct-type-name-form 17 | :documentation documentation-string 18 | 19 | :MUTABLE 20 | If mutable is provided for fields or the whole structure, 21 | setters are generated of the form SET--! 22 | and setf forms are generated for (setf (- struct-arg) value). 23 | 24 | :OPAQUE 25 | If opaque is NOT provided: 26 | - a recursive EQUAL? test is generated to test equality of each field. Otherwise only identity is tested. 27 | - (struct->list p) creates a list that looks like a constructor call. This is used when printing the object. 28 | - (struct-accessors p) returns a list of all of the accessors associated with transparent structure p. 29 | 30 | :SUPER super-struct-type-name-form 31 | If a super-type symbol is specified, this structure will inherit all of the accessors, setters, and predicates from 32 | the super classes in addition to the fields provided by field-specs. 33 | 34 | Returns a list of newly defined symbols." 35 | ;; TODO: issue when a transparent object inherits from an opaque object 36 | ;; TODO: documentation-tags 37 | ;; TODO: guard-tags 38 | `(for-macros 39 | ,(struct-form type-name field-specs struct-options))) 40 | (export 'define-struct) 41 | 42 | (define-struct point (x y) :opaque) 43 | (let ((p (make-point 3 4))) 44 | (assert (equal? (list (point-x p) ;; 3 45 | (point-y p) ;; 4 46 | (point? p) ;; t 47 | (struct? p) ;; t 48 | (not (equal? (make-point 3 4) (make-point 3 4))) ;; t 49 | (not (equal? (struct-copy p) p)) ;; t 50 | (equal? p p)) ;; t 51 | (list 3 4 t t t t t))) 52 | (assert (string-starts-with? (format nil "~S" p) "# 75 | (list t t 3 4 5 t t)))) 76 | 77 | ;; Super-duper types 78 | (define-struct point4d (w) 79 | :super 'point3d) 80 | (let ((p4d (make-point4d 'x 'y 'z 'w))) 81 | (assert [(conjoin 'struct? 'point? 'point3d? 'point4d?) p4d]) 82 | (list (point-x p4d) 83 | (point-y p4d) 84 | (point3d-z p4d) 85 | (point4d-w p4d))) 86 | 87 | ;; Transparent structures 88 | (define-struct tpoint (x y)) 89 | (let ((p (make-tpoint 3 4))) 90 | (assert (every 'identity 91 | (list 92 | (equal? (struct->list p) '(make-tpoint 3 4)) 93 | (equal? (struct-accessors p) '(tpoint-x tpoint-y)) 94 | (string= (format nil "~S" '(make-tpoint 3 4)) (format nil "~S" p)) 95 | (equal? p p) 96 | (equal? (make-tpoint 3 4) (make-tpoint 3 4)))))) 97 | 98 | ;; Mutable structures 99 | (define-struct mpoint (x y) :mutable) 100 | (let ((p (make-mpoint 3 4))) 101 | (setf (mpoint-x p) 5) 102 | (setf (mpoint-y p) 6) 103 | (assert (equal? (struct->list p) '(make-mpoint 5 6))) 104 | (set-mpoint-x! p :x) 105 | (set-mpoint-y! p :y) 106 | (assert (equal? (struct->list p) '(make-mpoint :x :y)))) 107 | 108 | ;; Mutable fields 109 | (define-struct mpoint3 (x y (z :mutable))) 110 | (let ((p (make-mpoint3 3 4 5))) 111 | (setf (mpoint3-z p) 20) 112 | (assert (equal? p (make-mpoint3 3 4 20)))) 113 | 114 | ;; TODO: Guard-expressions 115 | #+nil 116 | (struct ipoint (x y) 117 | :guard (lambda (x y) 118 | (if (not (and (integerp x) (integerp y))) 119 | (error "ipoints require integer arguments. got: X=~S Y=~S" x y) 120 | (values x y)))) 121 | 122 | (uninstall-syntax!) 123 | -------------------------------------------------------------------------------- /src/define.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:schemeish.internals) 2 | 3 | (install-syntax!) 4 | 5 | (export 6 | (defmacro define (name-field &body body) 7 | "Essentially expands to (lexically (define name-field body...) (expose-functions ,name)). 8 | Returns the name of the defined function. 9 | 10 | For more information about lexically, see LEXICALLY. 11 | For more information about expose, see EXPOSE. 12 | For more information about the lisp-2 style lexical-body definition DEFINE, see TRANSFORM-LEXICAL-BODY2-DEFINE-SYMBOL-OR-PAIR." 13 | (let ((name (definition-name-field->name name-field))) 14 | `(for-macros 15 | (fmakunbound ',name) 16 | (lexically (define ,name-field ,@body) (expose-functions ,name)) 17 | ',name)))) 18 | 19 | (export 20 | (defmacro undefine (name-field &body ignored-body) 21 | "Expands to (fmakunbound name). Mimics the form of DEFINE." 22 | (declare (ignore ignored-body)) 23 | `(for-macros (fmakunbound ',(definition-name-field->name name-field))))) 24 | 25 | #; 26 | (progn 27 | (define TEST-2+ "Adds 2." (cl:lambda (&rest numbers) (apply #'+ 2 numbers))) 28 | (documentation #'test-2+ t) 29 | ;; => "Adds 2." 30 | (assert (= (test-2+ 1 2 3) 8)) 31 | 32 | (define (test) 33 | #d"Documentation" 34 | #g(*guard-clauses-enabled?*) 35 | (define a 1) 36 | (define-values (b c d) (values 2 3 4)) 37 | (define (e x) 38 | #d"Returns the number x." 39 | #g((numberp x)) 40 | x) 41 | (define (((f y) z) w) 42 | #g((numberp y) 43 | (numberp z) 44 | (numberp w)) 45 | (list y z w)) 46 | (list* a b c d (e 5) [[(f 6) 7] 8])) 47 | (assert (equal (test) '(1 2 3 4 5 6 7 8))) 48 | (documentation #'test t) 49 | "Documentation 50 | 51 | Parameters: NIL 52 | Definition Form: (TEST) 53 | 54 | TEST has the following guard clauses: 55 | (*GUARD-CLAUSES-ENABLED?*)" 56 | 57 | (progn 58 | (assert (equal (lexically 59 | (define test-x 1) 60 | (define (test-y) "test-y" (+ test-x 2)) 61 | (define (lexical-test-z) "tests z" (+ [test-y] test-x)) 62 | (define lexical-test-w 1) 63 | (expose ((lexical-test-y test-y) 64 | lexical-test-z) 65 | ((*lexical-test-x* test-x) 66 | lexical-test-w))) 67 | 68 | '(*LEXICAL-TEST-X* *lexical-test-w* LEXICAL-TEST-Y LEXICAL-TEST-Z))) 69 | 70 | (assert (= *lexical-test-w* 1)) 71 | (assert (= *lexical-test-x* 1)) 72 | (assert (= (lexical-test-y) 3)) 73 | (assert (= (lexical-test-z) 4)))) 74 | 75 | (uninstall-syntax!) 76 | -------------------------------------------------------------------------------- /src/documentation.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:schemeish.internals) 2 | 3 | (defvar *object-documentation-hash-table* (make-hash-table :weakness :key)) 4 | (export 5 | (defun documentable-object? (object) 6 | (or (typep object 'function) 7 | (typep object 'method-combination) 8 | (typep object 'standard-method) 9 | (typep object 'package)))) 10 | 11 | (export 12 | (defun set-object-documentation-source! (object documentation-source) 13 | "Updates the documentation source associated with the given object. 14 | Object may be a function, method-combination, standard-method, or package. 15 | Returns object." 16 | (assert (documentable-object? object)) 17 | (setf (gethash object *object-documentation-hash-table*) documentation-source) 18 | object)) 19 | 20 | (set-object-documentation-source! 21 | #'documentable-object? 22 | (function-doc :name 'documentable-object? 23 | :syntax '(documentable-object? object) 24 | :arguments-and-values `((object "An object")) 25 | :description "Returns true if object can have its documentation set using (setf (document object t) ...)")) 26 | (set-object-documentation-source! 27 | #'set-object-documentation-source! 28 | (function-doc :name 'set-object-documentation-source! 29 | :syntax '(set-object-documentation-source! object documentation-source) 30 | :arguments-and-values `((object "An object that satisfies " ,(function-reference 'documentable-object?)) 31 | (documentation-source "An object that will satisfy " ,(function-reference 'documentation-source?))) 32 | :description '("Updates the " documentation-source " associated with the given " 'object ". Returns " 'object ".") 33 | :examples () 34 | :side-effects `(("Updates " ,(variable-reference '*object-documentation-hash-table*))) 35 | :affected-by () 36 | :exceptional-situations `(("Error if " 'object " does not satisfy " ,(function-reference 'documentation-object?))) 37 | :see-also `(,(function-reference 'documentation-object?) ,(function-reference 'documentation-string) ,(function-reference 'documentation-source?) 38 | ,(function-reference 'object-documentation-source)) 39 | :notes ())) 40 | 41 | (defvar *variable-documentation-hash-table* (make-hash-table)) 42 | (defvar *type-documentation-hash-table* (make-hash-table)) 43 | (defvar *compiler-macro-documentation-hash-table* (make-hash-table)) 44 | (defvar *setf-documentation-hash-table* (make-hash-table)) 45 | 46 | (defun check-symbol (symbol) 47 | (unless (symbolp symbol) 48 | (error "Symbol expected to be a symbol type, but got: ~S" (type-of symbol)))) 49 | (defun check-name (name) 50 | (unless (or (symbolp name) (and (listp name) 51 | (= 2 (length name)) 52 | (eq 'cl:setf (first name)) 53 | (symbolp (second name)))) 54 | (error "Name expected to be a symbol or a list (setf symbol) but got: ~S" name))) 55 | 56 | 57 | (export 58 | (defun set-variable-documentation-source! (symbol documentation-source) 59 | "Updates the documentation source associated with the constant or dynamic variable named symbol. Returns symbol." 60 | (check-symbol symbol) 61 | (setf (gethash symbol *variable-documentation-hash-table*) documentation-source) 62 | symbol)) 63 | (export 64 | (defun set-type-documentation-source! (symbol documentation-source) 65 | "Updates the documentation source associated with the type named by symbol. Returns symbol." 66 | (check-symbol symbol) 67 | (setf (gethash symbol *type-documentation-hash-table*) documentation-source) 68 | symbol)) 69 | (export 70 | (defun set-compiler-macro-documentation-source! (name documentation-source) 71 | "Updates the documentation source associated with the compiler-macro named by NAME. Returns name." 72 | (check-name name) 73 | (setf (gethash name *compiler-macro-documentation-hash-table*) documentation-source) 74 | name)) 75 | (export 76 | (defun set-setf-documentation-source! (symbol documentation-source) 77 | "Updates the documentation source associated with the setf-expansion named by symbol. Returns symbol." 78 | (check-symbol symbol) 79 | (setf (gethash symbol *setf-documentation-hash-table*) documentation-source) 80 | symbol)) 81 | 82 | (set-object-documentation-source! 83 | #'set-variable-documentation-source! 84 | (function-doc :name 'set-variable-documentation-source! 85 | :syntax '(set-variable-documentation-source! symbol documentation-source) 86 | :arguments-and-values `((symbol "An object that satisfies " ,(function-reference 'symbolp)) 87 | (documentation-source "An object that will satisfy " ,(function-reference 'documentation-source?))) 88 | :description '("Updates the " 'documentation-source " associated with the given variable named " 'symbol ". Returns " 'symbol ".") 89 | :side-effects `(("Updates " ,(variable-reference '*variable-documentation-hash-table*))) 90 | :exceptional-situations `(("Error if OBJECT does not satisfy " ,(function-reference 'symbolp))) 91 | :see-also `(,(function-reference 'documentation-string) ,(function-reference 'documentation-source?) 92 | ,(function-reference 'variable-documentation-source)))) 93 | (set-object-documentation-source! 94 | #'set-type-documentation-source! 95 | (function-doc :name 'set-type-documentation-source! 96 | :syntax '(set-type-documentation-source! symbol documentation-source) 97 | :arguments-and-values `((symbol "An object that satisfies " ,(function-reference 'symbolp)) 98 | (documentation-source "An object that will satisfy " ,(function-reference 'documentation-source?))) 99 | :description '("Updates the " 'documentation-source " associated with the given type named " 'symbol ". Returns " 'symbol ".") 100 | :side-effects `(("Updates " ,(variable-reference '*type-documentation-hash-table*))) 101 | :exceptional-situations `(("Error if OBJECT does not satisfy " ,(function-reference 'symbolp))) 102 | :see-also `(,(function-reference 'documentation-string) ,(function-reference 'documentation-source?) 103 | ,(function-reference 'type-documentation-source)))) 104 | (set-object-documentation-source! 105 | #'set-compiler-macro-documentation-source! 106 | (function-doc :name 'set-compiler-macro-documentation-source! 107 | :syntax '(set-compiler-macro-documentation-source! name documentation-source) 108 | :arguments-and-values `((name "A function-name. Either a symbol or (cl:setf symbol)") 109 | (documentation-source "An object that will satisfy " ,(function-reference 'documentation-source?))) 110 | :description '("Updates the " 'documentation-source " associated with the given compiler-macro named " 'name ". Returns " 'name ".") 111 | :side-effects `(("Updates " ,(variable-reference '*compiler-macro-documentation-hash-table*))) 112 | :exceptional-situations `(("Error if OBJECT does not satisfy " ,(function-reference 'symbolp))) 113 | :see-also `(,(function-reference 'documentation-string) ,(function-reference 'documentation-source?) 114 | ,(function-reference 'compiler-macro-documentation-source)))) 115 | (set-object-documentation-source! 116 | #'set-setf-documentation-source! 117 | (function-doc :name 'set-setf-documentation-source! 118 | :syntax '(set-setf-documentation-source! symbol documentation-source) 119 | :arguments-and-values `((symbol "An object that satisfies " ,(function-reference 'symbolp)) 120 | (documentation-source "An object that will satisfy " ,(function-reference 'documentation-source?))) 121 | :description '("Updates the " 'documentation-source " associated with the given setf expansion named " 'symbol ". Returns " 'symbol ".") 122 | :side-effects `(("Updates " ,(variable-reference '*setf-documentation-hash-table*))) 123 | :exceptional-situations `(("Error if OBJECT does not satisfy " ,(function-reference 'symbolp))) 124 | :see-also `(,(function-reference 'documentation-string) ,(function-reference 'documentation-source?) 125 | ,(function-reference 'setf-documentation-source)))) 126 | 127 | (export 128 | (defun variable-documentation-source (symbol) 129 | "Returns the documentation source associated with the constant or dynamic variable named symbol." 130 | (check-symbol symbol) 131 | (gethash symbol *variable-documentation-hash-table* nil))) 132 | (export 133 | (defun type-documentation-source (symbol) 134 | "Returns the documentation source associated with the type named by symbol." 135 | (check-symbol symbol) 136 | (gethash symbol *type-documentation-hash-table* nil))) 137 | (export 138 | (defun compiler-macro-documentation-source (name) 139 | "Returns the documentation source associated with the compiler-macro named by NAME." 140 | (check-name name) 141 | (gethash name *compiler-macro-documentation-hash-table* nil))) 142 | (export 143 | (defun setf-documentation-source (symbol) 144 | "Returns the documentation source associated with the setf-expansion named by symbol." 145 | (check-symbol symbol) 146 | (gethash symbol *setf-documentation-hash-table* nil))) 147 | (export 148 | (defun object-documentation-source (object) 149 | "Returns the documentation source associated with the given object. 150 | Object may be a function, method-combination, standard-method, or package." 151 | (assert (documentable-object? object)) 152 | (gethash object *object-documentation-hash-table* nil))) 153 | 154 | (set-object-documentation-source! 155 | #'variable-documentation-source 156 | (function-doc :name 'variable-documentation-source 157 | :syntax '(variable-documentation-source symbol) 158 | :arguments-and-values `((symbol "An object that satisfies " ,(function-reference 'symbolp))) 159 | :description '("Returns the " documentation-source " associated with the variable named by " symbol ", or NIL.") 160 | :affected-by `(,(variable-reference '*variable-documentation-hash-table*)) 161 | :exceptional-situations `(("Error if " symbol " does not satisfy " ,(function-reference 'symbolp))) 162 | :see-also `(,(function-reference 'documentation-source?) ,(function-reference 'set-variable-documentation-source!)))) 163 | (set-object-documentation-source! 164 | #'type-documentation-source 165 | (function-doc :name 'type-documentation-source 166 | :syntax '(type-documentation-source symbol) 167 | :arguments-and-values `((symbol "An object that satisfies " ,(function-reference 'symbolp))) 168 | :description '("Returns the " documentation-source " associated with the type named by " symbol ", or NIL.") 169 | :affected-by `(,(variable-reference '*type-documentation-hash-table*)) 170 | :exceptional-situations `(("Error if " symbol " does not satisfy " ,(function-reference 'symbolp))) 171 | :see-also `(,(function-reference 'documentation-source?) ,(function-reference 'set-type-documentation-source!)))) 172 | (set-object-documentation-source! 173 | #'compiler-macro-documentation-source 174 | (function-doc :name 'compiler-macro-documentation-source 175 | :syntax '(compiler-macro-documentation-source name) 176 | :arguments-and-values `((name "A function-name.")) 177 | :description '("Returns the " documentation-source " associated with the compiler-macro named by " name ", or NIL.") 178 | :affected-by `(,(variable-reference '*compiler-macro-documentation-hash-table*)) 179 | :exceptional-situations `(("Error if " name " is not a function-name")) 180 | :see-also `(,(function-reference 'documentation-source?) ,(function-reference 'set-compiler-macro-documentation-source!)))) 181 | (set-object-documentation-source! 182 | #'setf-documentation-source 183 | (function-doc :name 'setf-documentation-source 184 | :syntax '(setf-documentation-source symbol) 185 | :arguments-and-values `((symbol "A symbol.")) 186 | :description '("Returns the " documentation-source " associated with the setf expansion named by " symbol ", or NIL.") 187 | :affected-by `(,(variable-reference '*setf-documentation-hash-table*)) 188 | :exceptional-situations `(("Error if " symbol " does not satisfy " ,(function-reference 'symbolp))) 189 | :see-also `(,(function-reference 'documentation-source?) ,(function-reference 'set-setf-documentation-source!)))) 190 | 191 | (export 192 | (defun set-object-documentation-from-documentation-source! (object documentation-source) 193 | "If documentation-source is non-nil, sets both the object documentation-source and documentation string." 194 | (when documentation-source 195 | (setf (documentation object t) (documentation-string documentation-source)) 196 | (set-object-documentation-source! object documentation-source)) 197 | object)) 198 | 199 | (defstruct documentation-tag 200 | "A documentation-tag is an form that has been tagged as documentation for use in a function-body. 201 | See also PARSE-METADATA-FROM-FUNCTION-BODY. 202 | With SCHEMEISH syntax enabled, #dDOCUMENTATION-FORM => #.(make-documentation-tag :form DOCUMENTATION-FORM)." 203 | form) 204 | 205 | (setf (fdefinition 'documentation-tag?) #'documentation-tag-p) 206 | (export '(documentation-tag make-documentation-tag documentation-tag-form documentation-tag?)) 207 | 208 | (defun read-documentation-tag (stream char n) 209 | "Dispatch-macro reader for documentation-tags. #dDOCUMENTATION-FORM => #.(make-documentation-tag :form DOCUMENTATION-FORM)" 210 | (declare (ignore char n)) 211 | (let ((form (read stream t (values) t))) 212 | (make-documentation-tag :form form))) 213 | (defmethod print-object ((object documentation-tag) stream) 214 | (format stream "#D~S" (documentation-tag-form object))) 215 | 216 | (assert (string= (print-object (make-documentation-tag :form "Documentation") nil) 217 | "#D\"Documentation\"")) 218 | 219 | (defgeneric documentation-string (documentation) 220 | (:documentation "Returns a documentation string given the provided documentation object.")) 221 | (defmethod documentation-string ((documentation string)) documentation) 222 | (export 'documentation-string) 223 | (export 224 | (defun documentation-source? (object) 225 | "An object is a documentation-source if it has a method implemented for documentation-string." 226 | (compute-applicable-methods #'documentation-string (list object)))) 227 | -------------------------------------------------------------------------------- /src/expand-stream-collect.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:schemeish.backend) 2 | 3 | (install-syntax!) 4 | 5 | (define (stream-collect-bindings-fn binding-names body) 6 | (let ((arg-name (gensym))) 7 | `(lambda (,arg-name) 8 | (destructuring-bind ,binding-names ,arg-name 9 | (declare (ignorable ,@binding-names)) 10 | ,@body)))) 11 | 12 | (define (stream-collect-filter-form binding-names test-form stream-form) 13 | `(stream-filter 14 | ,(stream-collect-bindings-fn binding-names (list test-form)) 15 | ,stream-form)) 16 | 17 | (stream-collect-filter-form '(i j) '(even? (+ i j)) :stream) 18 | '(STREAM-FILTER 19 | (LAMBDA (#:G586) 20 | (DESTRUCTURING-BIND (I J) #:G586 (DECLARE (IGNORABLE I J)) (EVEN? (+ I J)))) 21 | :STREAM) 22 | 23 | (define (stream-collect-inner-map-form binding binding-names) 24 | `(stream-map (lambda (,(first binding)) 25 | (list ,@binding-names)) 26 | ,(second binding))) 27 | 28 | (assert (equal? (stream-collect-inner-map-form '(j (stream-range 1 (1- i))) 29 | '(i j)) 30 | '(STREAM-MAP 31 | (LAMBDA (J) 32 | (LIST I J)) 33 | (STREAM-RANGE 1 (1- I))))) 34 | 35 | (define (stream-collect-flatmap-form binding body) 36 | `(stream-flatmap (lambda (,(first binding)) 37 | ,@body) 38 | ,(second binding))) 39 | 40 | (assert (equal? (stream-collect-flatmap-form '(i (stream-range 1 n)) '(:body)) 41 | '(STREAM-FLATMAP 42 | (LAMBDA (I) 43 | :BODY) 44 | (STREAM-RANGE 1 N)))) 45 | 46 | (define (stream-collect-outer-map binding-names form stream) 47 | `(stream-map 48 | ,(stream-collect-bindings-fn binding-names (list form)) 49 | ,stream)) 50 | 51 | (stream-collect-outer-map '(i j) '(list i j (+ i j)) :stream) 52 | '(STREAM-MAP 53 | (LAMBDA (#:G588) 54 | (DESTRUCTURING-BIND 55 | (I J) 56 | #:G588 57 | (DECLARE (IGNORABLE I J)) 58 | (LIST I J (+ I J)))) 59 | :STREAM) 60 | 61 | (define (stream-collect-inner-flatmaps bindings) 62 | (when (null? bindings) 63 | (error "stream-collect: requires at least one binding.")) 64 | (let ((binding-names (map 'car bindings)) 65 | (bindings (reverse bindings))) 66 | (let rec ((result (stream-collect-inner-map-form (first bindings) 67 | binding-names)) 68 | (bindings (rest bindings))) 69 | (if (null? bindings) 70 | result 71 | (rec 72 | (stream-collect-flatmap-form (first bindings) (list result)) 73 | (rest bindings)))))) 74 | 75 | (assert (equal? (stream-collect-inner-flatmaps '((i (stream-range 1 n)) 76 | (j (stream-range 1 (1- i))))) 77 | '(STREAM-FLATMAP 78 | (LAMBDA (I) 79 | (STREAM-MAP 80 | (LAMBDA (J) 81 | (LIST I J)) 82 | (STREAM-RANGE 1 (1- I)))) 83 | (STREAM-RANGE 1 N)))) 84 | 85 | (define (stream-collect-form map-form bindings filter-form) 86 | (let ((binding-names (map 'car bindings))) 87 | (stream-collect-outer-map 88 | binding-names 89 | map-form 90 | (stream-collect-filter-form 91 | binding-names 92 | filter-form 93 | (stream-collect-inner-flatmaps bindings))))) 94 | 95 | 96 | (stream-collect-form '(list i j (+ i j)) 97 | '((i (stream-range 1 n)) 98 | (j (stream-range 1 (1- i)))) 99 | '(even? (+ i j))) 100 | '(STREAM-MAP 101 | (LAMBDA (#:G594) 102 | (DESTRUCTURING-BIND 103 | (I J) 104 | #:G594 105 | (DECLARE (IGNORABLE I J)) 106 | (LIST I J (+ I J)))) 107 | (STREAM-FILTER 108 | (LAMBDA (#:G593) 109 | (DESTRUCTURING-BIND 110 | (I J) 111 | #:G593 112 | (DECLARE (IGNORABLE I J)) 113 | (EVEN? (+ I J)))) 114 | (STREAM-FLATMAP 115 | (LAMBDA (I) 116 | (STREAM-MAP 117 | (LAMBDA (J) 118 | (LIST I J)) 119 | (STREAM-RANGE 1 (1- I)))) 120 | (STREAM-RANGE 1 N)))) 121 | 122 | 123 | (uninstall-syntax!) 124 | -------------------------------------------------------------------------------- /src/expand-struct.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:schemeish.backend) 2 | 3 | (install-syntax!) 4 | 5 | (defclass struct () () 6 | (:documentation "The base type for structures defined using DEFINE-STRUCT.")) 7 | (define (struct? datum) 8 | (typep datum 'struct)) 9 | (defgeneric struct-copy (struct) 10 | (:documentation "Returns a shallow copy of struct.")) 11 | (defmethod struct-copy (struct) 12 | (error "Struct ~S is not a known structure type." struct)) 13 | (defgeneric struct->list (transparent-struct) 14 | (:documentation "Returns a list of the form '(constructor-name field-values) for the transparent structure.")) 15 | (defmethod struct->list (struct) 16 | (error "Struct ~S is not a transparent structure." struct)) 17 | (defgeneric struct-accessors (transparent-struct) 18 | (:documentation "Returns a list of accessor symbols for the transparent structure.")) 19 | (defmethod struct-accessors (struct) 20 | (error "Struct ~S is not a transparent structure." struct)) 21 | (export '(struct struct-copy struct->list struct-accessors struct?)) 22 | 23 | (define (make-struct-info type-name super-type-name field-names) 24 | (alist :type-name type-name 25 | :super-type-name super-type-name 26 | :field-names field-names)) 27 | (define (struct-info-type-name si) (alist-ref si :type-name)) 28 | (define (struct-info-super-type-name si) (alist-ref si :super-type-name)) 29 | (define (struct-info-field-names si) (alist-ref si :field-names)) 30 | 31 | (defvar *struct-info-table* 32 | (make-hash-table :test #'eq) 33 | "Hash Table from structure type-name->struct-info") 34 | 35 | (define (get-struct-info type-name) 36 | (gethash type-name *struct-info-table* nil)) 37 | (define (set-struct-info! info) 38 | (let* ((type-name (struct-info-type-name info)) 39 | (existing-info (get-struct-info type-name))) 40 | (when (and existing-info 41 | (or (not (equal? (struct-info-super-type-name info) 42 | (struct-info-super-type-name existing-info))) 43 | (not (equal? (struct-info-field-names info) 44 | (struct-info-field-names existing-info))))) 45 | (warn "Modifying structure ~S. Any sub-classed structures need to be recompiled." type-name)) 46 | (setf (gethash type-name *struct-info-table*) info))) 47 | 48 | (define (struct-info-ancestor-fields info) 49 | "Returns an alist of ((ancestor . fields) ... (parent . fields) (me . fields)) From oldest generation to youngest." 50 | (let ((super-type-name (struct-info-super-type-name info))) 51 | (cond 52 | ((null? super-type-name) 53 | (list (cons (struct-info-type-name info) (struct-info-field-names info)))) 54 | (t 55 | (let ((super-struct-info (get-struct-info super-type-name))) 56 | (cond 57 | ((null? super-struct-info) 58 | (error "The super type ~S does not exist in the *struct-info-table*" super-type-name)) 59 | (t (append 60 | (struct-info-ancestor-fields super-struct-info) 61 | (list (cons (struct-info-type-name info) (struct-info-field-names info))))))))))) 62 | 63 | (define (struct-defclass-slot-name type-name field-name) 64 | (intern (string-append (symbol->string type-name) "-" (symbol->string field-name)))) 65 | 66 | (define (struct-defclass-slot-names type-name field-names) 67 | (map (lambda (field-name) (struct-defclass-slot-name type-name field-name)) 68 | field-names)) 69 | 70 | (assert (equal? (struct-defclass-slot-names 'point '(x y)) 71 | '(point-x point-y))) 72 | (define (ancestor-fields->field-names ancestor-fields) 73 | (append-map 'cdr ancestor-fields)) 74 | (define (ancestor-fields->slot-names ancestor-fields) 75 | (append* (alist-map ancestor-fields 76 | (lambda (type-name field-names) 77 | (struct-defclass-slot-names type-name field-names))))) 78 | 79 | (let ((*struct-info-table* (make-hash-table :test #'eq))) 80 | (set-struct-info! (make-struct-info 'grandpa () '(father))) 81 | (set-struct-info! (make-struct-info 'father 'grandpa '(son))) 82 | (set-struct-info! (make-struct-info 'son 'father '(grandpa))) 83 | 84 | (let ((ancestor-fields (struct-info-ancestor-fields (get-struct-info 'son)))) 85 | (assert (equal? (ancestor-fields->field-names ancestor-fields) 86 | '(father son grandpa))) 87 | (assert (equal? (ancestor-fields->slot-names ancestor-fields) 88 | '(grandpa-father father-son son-grandpa))))) 89 | 90 | 91 | (define (parse-struct-field-spec field-spec) 92 | (cond 93 | ((symbol? field-spec) (cons field-spec :immutable)) 94 | ((and (pair? field-spec) 95 | (symbol? (first field-spec))) 96 | (cond 97 | ((equal? (rest field-spec) '(:mutable)) 98 | (cons (first field-spec) :mutable)) 99 | (t (error "Unknown field-option(s): ~S" (rest field-spec))))) 100 | (t (error "bad thing to be a field-spec: ~S" field-spec)))) 101 | 102 | (assert (equal (parse-struct-field-spec 'field-name) 103 | '(FIELD-NAME . :IMMUTABLE))) 104 | (assert (equal (parse-struct-field-spec '(field-name :mutable)) 105 | '(FIELD-NAME . :MUTABLE))) 106 | 107 | (define (parse-struct-options struct-options) 108 | (cond 109 | ((empty? struct-options) ()) 110 | (t 111 | (let ((opt (first struct-options))) 112 | (cond 113 | ((or (eq? :opaque opt) 114 | (eq? :mutable opt)) 115 | (cons (cons opt ()) (parse-struct-options (rest struct-options)))) 116 | ((or (eq? :documentation opt) 117 | (eq? :super opt)) 118 | (cond 119 | ((or (null? (rest struct-options)) 120 | (keywordp (second struct-options))) 121 | (error "Expected form for struct-option ~S" opt)) 122 | (t 123 | (cons (cons opt (eval (second struct-options))) (parse-struct-options (cddr struct-options)))))) 124 | (t (error "Bad thing to be a struct-option ~S" opt))))))) 125 | 126 | 127 | (assert (equal? (parse-struct-options '(:opaque :mutable :super 'point :documentation "docs")) 128 | '((:OPAQUE) (:MUTABLE) (:SUPER . POINT) (:DOCUMENTATION . "docs")))) 129 | 130 | (define (struct-constructor-name type-name) 131 | (intern (string-append (symbol->string 'make-) (symbol->string type-name)))) 132 | 133 | (assert (eq? (struct-constructor-name 'point) 134 | 'make-point)) 135 | 136 | (define (struct-defclass-form type-name field-names super-type-name documentation) 137 | (let ((supers (cond ((null? super-type-name) '(struct)) 138 | (t `(,super-type-name))))) 139 | `(defclass ,type-name ,supers 140 | ,(struct-defclass-slot-names type-name field-names) 141 | ,@(when documentation `((:documentation ,documentation)))))) 142 | 143 | (assert (equal? (struct-defclass-form 'point '(x y) () ()) 144 | '(DEFCLASS POINT (struct) (point-x point-y)))) 145 | 146 | (assert (equal? (struct-defclass-form 'point3 '(z) 'point ()) 147 | '(DEFCLASS POINT3 (point) (point3-z)))) 148 | 149 | (define (struct-define-constructor-form type-name constructor-name field-names super-type-name) 150 | (let* ((ancestor-fields (struct-info-ancestor-fields (get-struct-info super-type-name))) 151 | (super-field-names (ancestor-fields->field-names ancestor-fields)) 152 | (super-slot-names (ancestor-fields->slot-names ancestor-fields))) 153 | `(define (,constructor-name ,@(append super-field-names field-names)) 154 | (let ((struct (make-instance ',type-name))) 155 | ,@(map (lambda (slot-name value-name) 156 | `(setf (slot-value struct ',slot-name) ,value-name)) 157 | super-slot-names 158 | super-field-names) 159 | ,@(map (lambda (slot-name value-name) 160 | `(setf (slot-value struct ',slot-name) ,value-name)) 161 | (struct-defclass-slot-names type-name field-names) 162 | field-names) 163 | struct)))) 164 | 165 | (assert (equal? (struct-define-constructor-form 'point 'make-point '(x y) '()) 166 | '(DEFINE (MAKE-POINT X Y) 167 | (LET ((STRUCT (MAKE-INSTANCE 'POINT))) 168 | (SETF (SLOT-VALUE STRUCT 'POINT-X) X) 169 | (SETF (SLOT-VALUE STRUCT 'POINT-Y) Y) 170 | STRUCT)))) 171 | 172 | (let ((*struct-info-table* (make-hash-table))) 173 | (set-struct-info! (make-struct-info 'point () '(x y))) 174 | 175 | (assert (equal? (struct-define-constructor-form 'point3 'make-point3 '(z) 'point) 176 | '(DEFINE (MAKE-POINT3 X Y Z) 177 | (LET ((STRUCT (MAKE-INSTANCE 'POINT3))) 178 | (SETF (SLOT-VALUE STRUCT 'POINT-X) X) 179 | (SETF (SLOT-VALUE STRUCT 'POINT-Y) Y) 180 | (SETF (SLOT-VALUE STRUCT 'POINT3-Z) Z) 181 | STRUCT))))) 182 | 183 | (define (struct-define-struct-copy-form type-name field-names super-type-name) 184 | (let* ((ancestor-fields (struct-info-ancestor-fields (get-struct-info super-type-name))) 185 | (super-slot-names (ancestor-fields->slot-names ancestor-fields))) 186 | `(defmethod struct-copy ((struct ,type-name)) 187 | (let ((copy (make-instance ',type-name))) 188 | ,@(map (lambda (slot-name) 189 | `(setf (slot-value copy ',slot-name) (slot-value struct ',slot-name))) 190 | super-slot-names) 191 | ,@(map (lambda (slot-name) 192 | `(setf (slot-value copy ',slot-name) (slot-value struct ',slot-name))) 193 | (struct-defclass-slot-names type-name field-names)) 194 | copy)))) 195 | 196 | (define (struct-define-struct->list-form type-name field-names super-type-name) 197 | (let* ((ancestor-fields (struct-info-ancestor-fields (get-struct-info super-type-name))) 198 | (super-slot-names (ancestor-fields->slot-names ancestor-fields))) 199 | `(defmethod struct->list ((struct ,type-name)) 200 | (list 201 | ',(struct-constructor-name type-name) 202 | ,@(map (lambda (slot-name) `(slot-value struct ',slot-name)) super-slot-names) 203 | ,@(map (lambda (slot-name) `(slot-value struct ',slot-name)) (struct-defclass-slot-names type-name field-names)))))) 204 | 205 | (define (struct-define-accessor-form type-name slot-name) 206 | `(define (,slot-name ,type-name) 207 | (slot-value ,type-name ',slot-name))) 208 | 209 | (assert (equal? (struct-define-accessor-form 'point 'point-x) 210 | '(DEFINE (POINT-X POINT) 211 | (SLOT-VALUE POINT 'POINT-X)))) 212 | 213 | (define (struct-define-struct-accessors-form type-name field-names super-type-name) 214 | (let* ((ancestor-fields (struct-info-ancestor-fields (get-struct-info super-type-name))) 215 | (super-slot-names (ancestor-fields->slot-names ancestor-fields))) 216 | `(defmethod struct-accessors ((struct ,type-name)) 217 | '(,@(append 218 | (map (lambda (slot-name) slot-name) super-slot-names) 219 | (map (lambda (slot-name) slot-name) (struct-defclass-slot-names type-name field-names))))))) 220 | 221 | (define (struct-define-field-setter-forms type-name field-name) 222 | (let ((setter-name (intern (string-append "SET-" (symbol->string type-name) "-" (symbol->string field-name) "!"))) 223 | (slot-name (struct-defclass-slot-name type-name field-name))) 224 | `(progn 225 | (define (,setter-name ,type-name value) 226 | (setf (slot-value ,type-name ',slot-name) value) 227 | value) 228 | (defsetf ,slot-name ,setter-name)))) 229 | 230 | (define (struct-define-equal?-form type-name field-names super-type-name) 231 | (let* ((ancestor-fields (struct-info-ancestor-fields (get-struct-info super-type-name))) 232 | (super-slot-names (ancestor-fields->slot-names ancestor-fields))) 233 | `(defmethod equal? ((object1 ,type-name) (object2 ,type-name)) 234 | (and 235 | ,@(append 236 | (map (lambda (slot-name) 237 | `(equal? (slot-value object1 ',slot-name) 238 | (slot-value object2 ',slot-name))) 239 | super-slot-names) 240 | (map (lambda (slot-name) 241 | `(equal? (slot-value object1 ',slot-name) 242 | (slot-value object2 ',slot-name))) 243 | (struct-defclass-slot-names type-name field-names))))))) 244 | 245 | (defparameter *self-evaluating-symbols* '(t nil)) 246 | (define (printable-field field) 247 | "Returns symbols as '(quote symbol), lists as '(list ...), 248 | dotted-lists as '(dotted-list ...) and conses as '(cons ...). 249 | For lists containing a cycle, just returns the list as is." 250 | (cond ((and (symbol? field) 251 | (not (keywordp field)) 252 | (not (member field *self-evaluating-symbols*))) 253 | `',field) 254 | ((pair? field) 255 | ;; Field is a list, list*, cons, or a cycle 256 | (let recurse ((xs field) 257 | (visited ()) 258 | (result ())) 259 | (cond 260 | ((empty? xs) 261 | ;; We are in a proper list 262 | `(list ,@(map #'printable-field field))) 263 | ((member xs visited) 264 | ;; We are in a cycle, just return the field 265 | field) 266 | ((pair? xs) 267 | ;; In the middle of the list, keep looking. 268 | (recurse (rest xs) (cons xs visited) (cons (first xs) result))) 269 | (t 270 | ;; xs is not empty or a list, we are in a dotted list or cons. 271 | (cond 272 | ;; Dotted-list 273 | ((pair? (rest field)) `(list* ,@(nreverse (map #'printable-field (cons xs result))))) 274 | (t `(cons ,(printable-field (car field)) ,(printable-field (cdr field))))))))) 275 | ;; Field is something else. Just print it. 276 | (t field))) 277 | 278 | (assert (equal? (printable-field :a) :a)) 279 | (assert (equal? (printable-field 'a) '(quote a))) 280 | (assert (equal? (printable-field 1) 1)) 281 | (assert (equal? (printable-field (list 1 2 3)) 282 | '(list 1 2 3))) 283 | (assert (equal? (printable-field (cons 1 (cons 2 3))) 284 | '(list* 1 2 3))) 285 | (assert (equal? (printable-field (cons 1 2)) 286 | '(cons 1 2))) 287 | (assert (equal? (printable-field (list (list 1) (list 2 (list 3)))) 288 | '(LIST (LIST 1) (LIST 2 (LIST 3))))) 289 | 290 | (define (print-transparent-struct struct stream) 291 | (let ((list (struct->list struct))) 292 | (print-object (cons (first list) (map #'printable-field (rest list))) 293 | stream))) 294 | 295 | (define (struct-define-print-object-form type-name) 296 | `(defmethod print-object ((struct ,type-name) stream) 297 | (print-transparent-struct struct stream))) 298 | 299 | (define (struct-define-type-predicate-form type-name predicate-name) 300 | `(define (,predicate-name datum) 301 | (typep datum ',type-name))) 302 | 303 | (assert (equal? (struct-define-type-predicate-form 'point 'point?) 304 | '(DEFINE (POINT? DATUM) 305 | (TYPEP DATUM 'POINT)))) 306 | 307 | (define (struct-form type-name field-specs struct-options) 308 | (let* ((parsed-field-specs (map 'parse-struct-field-spec field-specs)) 309 | (field-names (map 'car parsed-field-specs)) 310 | (slot-names (struct-defclass-slot-names type-name field-names)) 311 | (parsed-struct-options (parse-struct-options struct-options)) 312 | (super-type-name (alist-ref parsed-struct-options :super nil)) 313 | (constructor-name (struct-constructor-name type-name)) 314 | (predicate-name (intern (string-append (symbol->string type-name) "?")))) 315 | `(progn 316 | (set-struct-info! (make-struct-info ',type-name ',super-type-name ',field-names)) 317 | ,(struct-defclass-form type-name field-names super-type-name (alist-ref parsed-struct-options :documentation)) 318 | ,(struct-define-struct-copy-form type-name field-names super-type-name) 319 | ,@(cond ((not (alist-has-key? parsed-struct-options :opaque)) 320 | (list 321 | (struct-define-struct->list-form type-name field-names super-type-name) 322 | (struct-define-struct-accessors-form type-name field-names super-type-name) 323 | (struct-define-equal?-form type-name field-names super-type-name) 324 | (struct-define-print-object-form type-name))) 325 | (t ())) 326 | ,@(cond ((alist-has-key? parsed-struct-options :mutable) 327 | (map (lambda (field-name) 328 | (struct-define-field-setter-forms type-name field-name)) 329 | field-names)) 330 | (t 331 | (map (lambda (field-spec) 332 | (struct-define-field-setter-forms type-name (car field-spec))) 333 | (filter (lambda (field-spec) (eq? (cdr field-spec) :mutable)) 334 | parsed-field-specs)))) 335 | ,(struct-define-constructor-form type-name constructor-name 336 | field-names 337 | super-type-name) 338 | ,@(map (lambda (slot-name) (struct-define-accessor-form type-name slot-name)) 339 | slot-names) 340 | ,(struct-define-type-predicate-form type-name predicate-name) 341 | '(,type-name ,constructor-name ,predicate-name ,@slot-names)))) 342 | 343 | (struct-form 'point '(x y) '()) 344 | (struct-form 'point3 '(z) '(:super 'point)) 345 | (struct-form 'tpoint '(x y) '(:opaque)) 346 | (struct-form 'mpoint '(x y) '(:mutable)) 347 | (struct-form 'mypoint '(x (y :mutable)) '()) 348 | (struct-form 'mypoint '(x y) '(:documentation "docstring")) 349 | 350 | (uninstall-syntax!) 351 | -------------------------------------------------------------------------------- /src/expose.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:schemeish.internals) 2 | 3 | 4 | (defun lexical-name->parameter-name (symbol) 5 | "Adds *ear-muffs* to symbol to make it look like a parameter, interning it." 6 | (intern (concatenate 'string "*" (symbol-name symbol) "*"))) 7 | 8 | (defun check-expose-spec (spec name) 9 | "Error if EXPOSE SPEC is malformed." 10 | (unless (or (symbolp spec) 11 | (and (= (length spec) 2) 12 | (symbolp name))) 13 | (error "Malformed spec ~S: Expected NAME or (GLOBAL-NAME VALUE)" spec))) 14 | (defun expose-function-form (fn-spec) 15 | "Returns a (setf fdefinition) form for fn-spec." 16 | (let* ((pair? (consp fn-spec)) 17 | (name (if pair? (first fn-spec) fn-spec)) 18 | (value (if pair? (second fn-spec) fn-spec))) 19 | (check-expose-spec fn-spec name) 20 | `(progn (setf (fdefinition ',name) ,value) ',name))) 21 | 22 | (defun expose-variable-form (var-spec) 23 | "Returns a defparameter form for var-spec." 24 | ;; TODO: allow for documentation 25 | (let* ((pair? (consp var-spec)) 26 | (name (if pair? (first var-spec) (lexical-name->parameter-name var-spec))) 27 | (value (if pair? (second var-spec) var-spec))) 28 | (check-expose-spec var-spec name) 29 | `(defparameter ,name ,value))) 30 | 31 | (export 32 | (defmacro expose ((&rest fn-specs) (&rest var-specs)) 33 | "Define var-specs as parameters in the global scope via DEFPARAMETER. 34 | Define fn-specs as functions in the global scope via (SETF FDEFINITION). 35 | Designed to be used within a lexical-body. See LEXICALLY, DEFINE. 36 | 37 | Fn-spec is one of: 38 | fn-name: Expands to (setf (fdefinition 'fn-name) fn-name) 39 | (global-fn-name value): Expands to (setf (fdefinition 'global-fn-name) value) 40 | 41 | Var-spec one of: 42 | VAR-NAME: *Ear-muffs* are added to symbol to create *VAR-NAME*. Expands to (defparameter *var-name* var-name). 43 | (*global-special-name* value): Expands to (defparameter *global-special-name* value). 44 | 45 | The return value is (PARAMETER-NAMES... GLOBAL-FN-NAMES ...)" 46 | `(list ,@(mapcar #'expose-variable-form var-specs) ,@(mapcar #'expose-function-form fn-specs)))) 47 | 48 | (export 49 | (defmacro expose-functions (&rest fn-specs) 50 | "Expands to (EXPOSE (fn-specs...) ())" 51 | `(expose (,@fn-specs) ()))) 52 | 53 | (export 54 | (defmacro expose-variables (&rest var-specs) 55 | "Expands to (EXPOSE () (var-specs...))" 56 | `(expose () (,@var-specs)))) 57 | 58 | -------------------------------------------------------------------------------- /src/for-macros.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:schemeish.internals) 2 | 3 | (defmacro for-macros (&body body) 4 | "Expands to `(eval-when (:compile-toplevel :load-toplevel :execute) ,@body). 5 | Used to annotate functions and/or variable definitions that are used in macros." 6 | `(eval-when (:compile-toplevel :load-toplevel :execute) ,@body)) 7 | 8 | (defmacro no-compile (&body body) 9 | "Wrap body in an (eval-when (:load-toplevel :execute)). 10 | Useful for example code or top-level ASSERTs." 11 | `(eval-when (:load-toplevel :execute) 12 | ,@body)) 13 | 14 | (defmacro export-definition (&body body) 15 | "Expands to (FOR-MACROS (EXPORT (PROGN BODY...))) for use in top-level definition forms." 16 | `(for-macros 17 | (cl:export (progn ,@body)))) 18 | (export '(for-macros export-definition no-compile)) 19 | -------------------------------------------------------------------------------- /src/function-body.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:schemeish.internals) 2 | 3 | (defun declaration? (form) 4 | "True if form is (cl:declare ...)" 5 | (and (consp form) 6 | (eq (first form) 'cl:declare))) 7 | 8 | (export 9 | (defun parse-declarations (body) 10 | "Returns (values declarations forms)" 11 | (splitf body #'declaration?))) 12 | 13 | (defun parse-documentation-source (body) 14 | "Returns (values forms documentation-source). 15 | Body is (documentation-string form forms...) or ([documentation-tag] forms...) 16 | The documentation-source returned is either a DOCUMENTATION-TAG-FORM, a string, or nil. 17 | For more information about documentation-tags, see DOCUMENTATION-TAG, DOCUMENTATION-STRING, and DOCUMENTATION-SOURCE?" 18 | (cond 19 | ((null body) (values body nil)) 20 | ((documentation-tag? (first body)) 21 | (values (rest body) (documentation-tag-form (first body)))) 22 | ((and (not (null (rest body))) 23 | (stringp (first body))) 24 | (values (rest body) (first body))) 25 | (t (values body nil)))) 26 | 27 | (defun parse-guard-clauses (body) 28 | "Returns (values body guard-clauses). Assumes body is ([guard-tag] forms...)" 29 | (if (and (not (null body)) 30 | (guard-tag? (first body))) 31 | (values (rest body) (guard-tag-clauses (first body))) 32 | (values body nil))) 33 | 34 | (export 35 | (defun parse-metadata-from-function-body (function-body) 36 | "Return (values lexical-body documentation-source-form guard-clauses declarations). 37 | A function-body is ([documentation-source] [guard-tag] declarations... lexical-body...) 38 | For more information about DOCUMENTATION-SOURCE, see PARSE-DOCUMENTATION-SOURCE. 39 | For more information about guard-tags, see GUARD-TAG. 40 | For more information about lexical-body, see LEXICALLY." 41 | (multiple-value-bind (body documentation-source) (parse-documentation-source function-body) 42 | (multiple-value-bind (body guard-clauses) (parse-guard-clauses body) 43 | (multiple-value-bind (declarations body) (parse-declarations body) 44 | (values body documentation-source guard-clauses declarations)))))) 45 | 46 | (export 47 | (defun parse-function (scm-parameters function-body) 48 | "Returns (values ordinary-lambda-list ignorable-parameters body documentation-source guard-clauses declarations) 49 | Converts scm-parameters to an ordinary-lambda-list, and parses the metadata from function-body. 50 | For more information about scm-parameters, SCM-PARAMETERS->ORDINARY-LAMBDA-LIST. 51 | For more information about function-body, see PARSE-METADATA-FROM-FUNCTION-BODY." 52 | (multiple-value-call #'values 53 | (scm-parameters->ordinary-lambda-list scm-parameters) 54 | (parse-metadata-from-function-body function-body)))) 55 | 56 | (defun declare-ignorable-forms (ignorable-names) 57 | "Returns a list of forms that declare ignorable-names to be ignorable" 58 | (when ignorable-names 59 | (list `(declare (ignorable ,@ignorable-names))))) 60 | (defun enforce-guard-clauses-forms (guard-clauses ordinary-lambda-list) 61 | "Return a list of forms that enforce guard clauses." 62 | (when guard-clauses 63 | (list (enforce-guard-clauses-form guard-clauses (ordinary-lambda-list-parameter-bindings-form ordinary-lambda-list))))) 64 | 65 | (defun documentation-string-for-scm-parameters (scm-parameters) 66 | "A string documenting scm-parameters." 67 | (format nil "Parameters: ~S" scm-parameters)) 68 | 69 | (defun documentation-string-for-lambda (scm-parameters guard-clauses documentation-string) 70 | "Adds documentation for the lambda from the scm-parameters, guard-clauses, and the documentation-string." 71 | (concatenate 'string 72 | documentation-string 73 | (format nil "~&~%~%") 74 | (documentation-string-for-scm-parameters scm-parameters) 75 | (format nil "~&~%~%") 76 | (guard-clauses-documentation-string guard-clauses))) 77 | 78 | (defun register-lambda-metadata (function scm-parameters guard-clauses documentation-source) 79 | "Registers documentation, documentation-source, and guard-clauses for function." 80 | (let ((documentation-string (if documentation-source 81 | (documentation-string documentation-source) 82 | ""))) 83 | (setf (documentation function t) 84 | (documentation-string-for-lambda scm-parameters guard-clauses documentation-string))) 85 | (when guard-clauses (register-guard-clauses function guard-clauses)) 86 | (when documentation-source (set-object-documentation-source! function documentation-source)) 87 | function) 88 | 89 | 90 | (defun parsed-function->lambda-form (ordinary-lambda-list ignorable-parameters body guard-clauses declarations) 91 | "Return a lambda form that: 92 | - declares ignorable-parameters alongside declarations 93 | - enforces guard-clauses 94 | - expands body as if it is a lisp-2 style lexical-body" 95 | `(cl:lambda ,ordinary-lambda-list 96 | ,@(declare-ignorable-forms ignorable-parameters) 97 | ,@declarations 98 | ,@(enforce-guard-clauses-forms guard-clauses ordinary-lambda-list) 99 | (lexically ,@body))) 100 | 101 | (export 102 | (defun lambda-form (scm-parameters function-body) 103 | "Return a form that, when evaluated, creates a lambda defined using the scm-parameters and function-body. 104 | See PARSE-FUNCTION and REGISTER-LAMBDA-METADATA." 105 | (multiple-value-bind (ordinary-lambda-list ignorable-parameters body documentation-source guard-clauses declarations) 106 | (parse-function scm-parameters function-body) 107 | `(register-lambda-metadata 108 | ,(parsed-function->lambda-form ordinary-lambda-list ignorable-parameters body guard-clauses declarations) 109 | ',scm-parameters ',guard-clauses ,documentation-source)))) 110 | 111 | -------------------------------------------------------------------------------- /src/function-combinators.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:function-combinators 2 | (:use :schemeish.schemeish)) 3 | 4 | (in-package #:function-combinators) 5 | 6 | (shadow '(schemeish.schemeish:compose* schemeish.schemeish:compose)) 7 | 8 | (install-syntax!) 9 | 10 | (defparameter *arity-table* (make-hash-table :weakness :key)) 11 | 12 | (export 13 | (define (restrict-arity proc arity) 14 | "Restricts the arity (see GET-ARITY) for proc." 15 | (hash-set! *arity-table* proc arity) 16 | proc)) 17 | 18 | (export 19 | (define (get-arity proc) 20 | "Gets the procedure-arity or restricted arity for proc." 21 | (or (hash-ref *arity-table* proc) 22 | (procedure-arity proc)))) 23 | 24 | (export 25 | (define (compose* procs) 26 | "Return the composition of procs with restricted arity." 27 | (foldr (lambda (f g) 28 | (restrict-arity 29 | (lambda args 30 | (multiple-value-call f (apply g args))) 31 | (get-arity g))) 32 | #'values procs))) 33 | 34 | (export 35 | (define (compose . procs) 36 | "Return the composition of procs with restricted arity." 37 | (compose* procs))) 38 | 39 | (define (match-arity-specs spec-a spec-b) 40 | "Returns an arity-spec that matches spec-a and spec-b, or NIL if they cannot match." 41 | (define (rest-spec? spec) 42 | (and (list? spec) (eq? (first spec) :*))) 43 | (define (other-keys-spec? spec) 44 | (and (list? spec) (eq? (first spec) :**))) 45 | 46 | (define (match-other-keys-and-number other-keys number) 47 | (let ((n (cdr other-keys))) 48 | (when (and (eq? (even? n) (even? number)) 49 | (>= number n)) 50 | number))) 51 | (define (match-rest-and-number rest number) 52 | (let ((n (cdr rest))) 53 | (when (>= number n) 54 | number))) 55 | (define (match-other-keys-and-rest other-keys rest) 56 | (let ((n-other (cdr other-keys)) 57 | (n-rest (cdr rest))) 58 | (cond 59 | ((<= n-rest n-other) other-keys) 60 | ((eq? (even? n-rest) (even? n-other)) 61 | (cons :** n-rest)) 62 | (t 63 | (cons :** (1+ n-rest)))))) 64 | 65 | (cond 66 | ((and (number? spec-a) (number? spec-b) (= spec-a spec-b)) 67 | spec-a) 68 | ((and (rest-spec? spec-a) (rest-spec? spec-b)) 69 | (let ((na (cdr spec-a)) 70 | (nb (cdr spec-b))) 71 | (cons :* (max na nb)))) 72 | ((and (other-keys-spec? spec-a) (other-keys-spec? spec-b)) 73 | (let ((na (cdr spec-a)) 74 | (nb (cdr spec-b))) 75 | (when (eq? (even? na) (even? nb)) 76 | (cons :** (max na nb))))) 77 | 78 | ((and (rest-spec? spec-a) (number? spec-b)) 79 | (match-rest-and-number spec-a spec-b)) 80 | ((and (number? spec-a) (rest-spec? spec-b)) 81 | (match-rest-and-number spec-b spec-a)) 82 | 83 | ((and (other-keys-spec? spec-a) (number? spec-b)) 84 | (match-other-keys-and-number spec-a spec-b)) 85 | ((and (number? spec-a) (other-keys-spec? spec-b)) 86 | (match-other-keys-and-number spec-b spec-a)) 87 | 88 | ((and (other-keys-spec? spec-a) (rest-spec? spec-b)) 89 | (match-other-keys-and-rest spec-a spec-b)) 90 | ((and (rest-spec? spec-a) (other-keys-spec? spec-b)) 91 | (match-other-keys-and-rest spec-b spec-a)))) 92 | 93 | (assert (equal? (match-arity-specs 2 4) 94 | 'NIL)) 95 | (assert (equal? (match-arity-specs 2 2) 96 | '2)) 97 | 98 | (assert (equal? (match-arity-specs '(:* . 3) 2) 99 | NIL)) 100 | (assert (equal? (match-arity-specs '(:* . 3) 3) 101 | '3)) 102 | (assert (equal? (match-arity-specs '(:* . 3) 4) 103 | '4)) 104 | 105 | (assert (equal? (match-arity-specs '(:** . 4) 3) 106 | 'NIL)) 107 | (assert (equal? (match-arity-specs '(:** . 4) 4) 108 | '4)) 109 | (assert (equal? (match-arity-specs '(:** . 4) 5) 110 | NIL)) 111 | 112 | (assert (equal? (match-arity-specs '(:* . 2) '(:* . 3)) 113 | '(:* . 3))) 114 | 115 | (assert (equal? (match-arity-specs '(:** . 2) '(:** . 3)) 116 | 'nil)) 117 | (assert (equal? (match-arity-specs '(:** . 5) '(:** . 3)) 118 | '(:** . 5))) 119 | 120 | (assert (equal? (match-arity-specs '(:** . 3) '(:* . 3)) 121 | '(:** . 3))) 122 | (assert (equal? (match-arity-specs '(:** . 3) '(:* . 4)) 123 | '(:** . 5))) 124 | (assert (equal? (match-arity-specs '(:** . 3) '(:* . 6)) 125 | '(:** . 7))) 126 | 127 | (define (matching-arity arity-a arity-b) 128 | "Returns an arity that matches both a and b or NIL if no arities match." 129 | (define (loop-b result spec-a a b) 130 | (cond ((null? b) (loop-a result (rest a))) 131 | (t (let ((spec-b (first b))) 132 | (let ((match (match-arity-specs spec-a spec-b))) 133 | (loop-b (if match 134 | (adjoin match result :test #'equal?) 135 | result) 136 | spec-a 137 | a 138 | (rest b))))))) 139 | 140 | (define (loop-a result a) 141 | (cond ((null? a) result) 142 | (t (loop-b result (first a) a arity-b)))) 143 | 144 | (nreverse (loop-a () arity-a))) 145 | 146 | (assert (equal? (matching-arity '(2 4 (:** . 6)) 147 | '((:* . 3))) 148 | '(4 (:** . 6)))) 149 | 150 | 151 | (define (fixed-arity? arity) 152 | "True if arity has a single, numerical arity." 153 | (and (pair? arity) (null? (rest arity)) (number? (first arity)))) 154 | (define (fixed-arity-nargs arity) 155 | "Returns number of arguments in the fixed-arity." 156 | (first arity)) 157 | 158 | (export 159 | (define (parallel-apply f g) 160 | "return a function with an arity that matches f and g and applies args to both f and g and returns the values of f and g." 161 | (define (the-combination . args) 162 | (multiple-value-call #'values (apply f args) (apply g args))) 163 | (let ((arity (matching-arity (get-arity f) (get-arity g)))) 164 | (assert (not (null? arity))) 165 | (restrict-arity the-combination arity)))) 166 | 167 | (export 168 | (define (parallel-combine h f g) 169 | "return a function with an arity that matches f and g and applies args to both f and g and calls h with the results of f then g." 170 | (compose h (parallel-apply f g)))) 171 | 172 | (export 173 | (define (spread-apply f g) 174 | "Return a function with a fixed-arity which applies the first arguments to f and the rest of the arguments to g. Returns the values of f then g." 175 | (let ((arity-f (get-arity f)) 176 | (arity-g (get-arity g))) 177 | (assert (fixed-arity? arity-f)) 178 | (assert (fixed-arity? arity-g)) 179 | 180 | (let ((n (fixed-arity-nargs arity-f)) 181 | (m (fixed-arity-nargs arity-g))) 182 | 183 | (let ((o (+ n m))) 184 | (restrict-arity 185 | (lambda args 186 | (assert (= o (length args))) 187 | (multiple-value-call #'values 188 | (apply f (take args n)) 189 | (apply g (drop args n)))) 190 | (list o))))))) 191 | (export 192 | (define (spread-combine h f g) 193 | "Return a function with a fixed-arity which applies the first arguments to f and the rest of the arguments to g. Applies h to the return values of f then g." 194 | (compose h (spread-apply f g)))) 195 | 196 | (export 197 | (define (permute-arguments . permspec) 198 | "Return a function f, with arguments permuted according to permspec." 199 | (let ((permute (make-permutation permspec))) 200 | (lambda (f) 201 | (define (the-combination . args) 202 | (apply f [permute args])) 203 | (let ((n (get-arity f))) 204 | (assert (= n (length permspec))) 205 | (restrict-arity the-combination n)))))) 206 | 207 | (define (make-permutation permspec) 208 | (define (the-permuter lst) 209 | (map (lambda (p) (list-ref lst p)) 210 | permspec)) 211 | the-permuter) 212 | 213 | (define (add-arity arity-a nargs) 214 | (map (lambda (spec) 215 | (cond ((number? spec) (+ spec nargs)) 216 | (t (cons (car spec) (+ nargs (cdr spec)))))) 217 | arity-a)) 218 | (define (arity-has-nargs? arity nargs) 219 | (there-exists (lambda (spec) 220 | (cond ((number? spec) (= spec nargs)) 221 | ((eq? (car spec) :*) 222 | (<= (cdr spec) nargs)) 223 | ((eq? (car spec) :**) 224 | (let ((n (cdr spec))) 225 | (and (<= n nargs) 226 | (eq? (even? n) (even? nargs))))))) 227 | arity)) 228 | 229 | (define (list-remove lst index) 230 | (let lp ((lst lst) (index index)) 231 | (assert (pair? lst)) 232 | (if (= index 0) 233 | (cdr lst) 234 | (cons (car lst) (lp (cdr lst) (- index 1)))))) 235 | 236 | (define (list-insert lst index value) 237 | (let lp ((lst lst) (index index)) 238 | (if (= index 0) 239 | (cons value lst) 240 | (progn 241 | (assert (pair? lst)) 242 | (cons (car lst) (lp (cdr lst) (- index 1))))))) 243 | 244 | (define (make-discarder indices) 245 | (let ((sorted-indices (sort indices #'>))) 246 | (lambda (args) 247 | (foldl (lambda (index result) 248 | (list-remove result index)) 249 | args 250 | sorted-indices)))) 251 | 252 | (define (make-curryer indices args) 253 | (lambda (f-args) 254 | (foldl (lambda (index value result) 255 | (list-insert result index value)) 256 | args 257 | indices 258 | f-args))) 259 | 260 | (assert (equal? [(make-discarder '(1 2)) '(:a :b :c :d)] 261 | '(:A :D))) 262 | (assert (equal? [(make-curryer '(1 3) '(:a :c)) '(:b :d)] 263 | '(:A :B :C :D))) 264 | 265 | 266 | (export 267 | (define (discard-arguments . indices) 268 | (let ((discard (make-discarder indices)) 269 | (max-i (apply #'max indices))) 270 | (lambda (f) 271 | (let ((m (add-arity (get-arity f) (length indices)))) 272 | (assert (arity-has-nargs? m (1+ max-i))) 273 | (restrict-arity 274 | (lambda args 275 | (assert (arity-has-nargs? m (length args))) 276 | (apply f [discard args])) 277 | m)))))) 278 | 279 | (assert (equal? [[(discard-arguments 1 3) #'list] :a :b :c :d] 280 | '(:A :C))) 281 | 282 | (export 283 | (define ((curry-arguments . indices) . args) 284 | (let ((curry (make-curryer indices args)) 285 | (n (+ (length indices) (length args)))) 286 | (lambda (f) 287 | (assert (arity-has-nargs? (get-arity f) n)) 288 | (lambda f-args 289 | (apply f [curry f-args])))))) 290 | 291 | (assert (equal? [[[(curry-arguments 1 3) :a :c] #'list] :b :d] 292 | '(:A :B :C :D))) 293 | 294 | (uninstall-syntax!) 295 | -------------------------------------------------------------------------------- /src/group.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:schemeish.backend) 2 | 3 | (install-syntax!) 4 | 5 | ;;; List:Group 6 | 7 | (export 8 | (define (group key-fn list) 9 | "Groups elements of list that have the same key-fn into an alist." 10 | (define (rec list result) 11 | (cond 12 | ((null? list) 13 | (alist-map result 14 | (lambda (key list) 15 | (cons key (nreverse list))))) 16 | (t (let ((item (first list))) 17 | (let ((key [key-fn item])) 18 | (rec (rest list) 19 | (alist-update result key (lambda (vals) (cons item vals)) ()))))))) 20 | (rec list ()))) 21 | 22 | (assert (equal? (group 'car '((0 a b c) 23 | (1 a b c) 24 | (0 d e f) 25 | (2 a b c) 26 | (1 d e f))) 27 | '((1 (1 A B C) (1 D E F)) (2 (2 A B C)) (0 (0 A B C) (0 D E F))))) 28 | 29 | (uninstall-syntax!) 30 | -------------------------------------------------------------------------------- /src/guard.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:schemeish.internals) 2 | 3 | (defstruct guard-tag 4 | "A guard-tag is set of guard clauses that have been tagged as a guard for use in DEFINE. 5 | Each clause is an unevaluated form. When evaluated each form should return a boolean. 6 | When SCHEMEISH syntax is installed, #g(clauses...) is equaivalent to #.(make-guard-tag :clauses clauses)" 7 | clauses) 8 | (setf (fdefinition 'guard-tag?) #'guard-tag-p) 9 | (export '(guard-tag make-guard-tag guard-tag-clauses guard-tag?)) 10 | 11 | (export 12 | (defun read-guard-tag (stream char n) 13 | "Dispatch-macro reader for a guard-tag. #g(clauses...) => #.(make-guard-tag :clauses clauses)" 14 | (declare (ignore char n)) 15 | (let ((clauses (read stream t (values) t))) 16 | (unless (listp clauses) 17 | (error "Expected guard clauses to be a list of the form (guard-clause...). Got ~S" clauses)) 18 | (make-guard-tag :clauses clauses)))) 19 | 20 | (defmethod print-object ((guard guard-tag) stream) 21 | (let ((clauses (guard-tag-clauses guard))) 22 | (if (null clauses) 23 | (format stream "#G()") 24 | (format stream "#G~S" clauses)))) 25 | 26 | (assert (string= (print-object (make-guard-tag :clauses ()) nil) 27 | "#G()")) 28 | (assert (string= (print-object (make-guard-tag :clauses '((numberp x) (listp xs))) nil) 29 | "#G((NUMBERP X) (LISTP XS))")) 30 | 31 | (defvar *guard-clauses-enabled?* t) 32 | (export (defun guard-clauses-enabled? () 33 | "True if enforcement of guard-clauses are enabled in the current dynamic context." 34 | *guard-clauses-enabled?*)) 35 | (export (defun enable-guard-clauses! () 36 | "Enables enforcement of guard-clauses in the current dynamic context." 37 | (setq *guard-clauses-enabled?* t))) 38 | (export (defun disable-guard-clauses! () 39 | "Disables enforcement of guard-clauses in the current dynamic context." 40 | (setq *guard-clauses-enabled?* nil))) 41 | (export (defmacro with-guard-clauses-enabled (&body body) 42 | "Creates a dynamic context around body with guard-clauses enforced." 43 | `(cl:let ((*guard-clauses-enabled?* t)) 44 | ,@body))) 45 | (export (defmacro with-guard-clauses-disabled (&body body) 46 | "Creates a dynamic context around body with guard-clauses not enforced." 47 | `(cl:let ((*guard-clauses-enabled?* nil)) 48 | ,@body))) 49 | 50 | (defvar *guard-clauses-table* (make-hash-table :weakness :key) 51 | "A table from function to a list of guard-clauses guarding that function.") 52 | 53 | (defun register-guard-clauses (function guard-clauses) 54 | "Associates function with guard-clauses in the *guard-clauses-hash-table*" 55 | (assert (functionp function)) 56 | (assert (listp guard-clauses)) 57 | (setf (gethash function *guard-clauses-table*) guard-clauses) 58 | function) 59 | 60 | (export 61 | (defun registered-guard-clauses (function) 62 | "Retrieves the guard-clauses associated with function, or NIL if not present." 63 | (assert (functionp function)) 64 | (gethash function *guard-clauses-table*))) 65 | 66 | (defun guard-clauses-documentation-string (guard-clauses &optional name) 67 | "Returns a string documenting guard-clauses for name." 68 | (concatenate 69 | 'string 70 | (if name 71 | (format nil "~S has" name) 72 | "Has") 73 | (if guard-clauses 74 | (format nil " the following guard clauses:~%~S" guard-clauses) 75 | " no guard clauses."))) 76 | 77 | (defun enforce-guard-clauses-form (guard-clauses parameter-bindings-form) 78 | "Return a form that processes guard-clauses, causing an error if any clause fails. 79 | Checks if *guard-clauses-enabled?* is true before evaluating any guard clauses. 80 | Parameter-bindings-form is evaluates to a list of (parameter-name value) for parameters which will be provided in the error message." 81 | `(when *guard-clauses-enabled?* 82 | ,@(mapcar (cl:lambda (guard-clause) 83 | `(unless ,guard-clause 84 | ,(if parameter-bindings-form 85 | `(error "Failed function guard-clause: ~S with the given parameter bindings: ~S" ',guard-clause ,parameter-bindings-form) 86 | `(error "Failed function guard-clause: ~S" ',guard-clause)))) 87 | guard-clauses))) 88 | 89 | (assert (equal (enforce-guard-clauses-form '((numberp x) (listp xs)) '((x 3) (xs (1 2 3)))) 90 | '(WHEN *GUARD-CLAUSES-ENABLED?* 91 | (UNLESS (NUMBERP X) 92 | (ERROR 93 | "Failed function guard-clause: ~S with the given parameter bindings: ~S" 94 | '(NUMBERP X) ((X 3) (XS (1 2 3))))) 95 | (UNLESS (LISTP XS) 96 | (ERROR 97 | "Failed function guard-clause: ~S with the given parameter bindings: ~S" 98 | '(LISTP XS) ((X 3) (XS (1 2 3)))))))) 99 | -------------------------------------------------------------------------------- /src/hash-tables.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:schemeish.backend) 2 | 3 | (install-syntax!) 4 | 5 | ;;; Hash-tables 6 | 7 | (export 8 | (define (hash-ref table key (failure-result)) 9 | "Returns the value associated with key in the hash-table table or failure-result." 10 | (multiple-value-bind (value present?) (gethash key table) 11 | (if present? 12 | value 13 | failure-result)))) 14 | (export 15 | (define (hash-set! table key value) 16 | "Sets the value associated with key in hash-table table to value. Returns the value." 17 | (setf (gethash key table) value))) 18 | (export 19 | (define (hash-find-keyf table predicate (failure-result)) 20 | "Returns the first key that satisfies [predicate key] in table." 21 | (loop for key being the hash-keys in table 22 | do (when [predicate key] 23 | (return-from hash-find-keyf key))) 24 | failure-result)) 25 | 26 | (export 27 | (define (hash-ref-default table key delayed-value) 28 | "Return the value associated with key in table. 29 | If there is no value, computes [delayed-value] and stores it in the table 30 | before returning it." 31 | (let* ((no-value (gensym)) 32 | (value (hash-ref table key no-value))) 33 | (if (eq? no-value value) 34 | (hash-set! table key [delayed-value]) 35 | value)))) 36 | 37 | (export 38 | (define (hash-update! table key updater (failure-result)) 39 | "Updates the value in table associated with key using [updater value]. 40 | If no value is associated with key, failure-result is used instead." 41 | (hash-set! table key [updater (hash-ref table key failure-result)]))) 42 | 43 | (export 44 | (define (hash-map table proc) 45 | "Maps [proc key value] over the keys and values of table, producing a list as a result." 46 | (loop for key being the hash-keys of table using (hash-value value) 47 | collecting [proc key value]))) 48 | 49 | (export 50 | (define (hash-keys table) 51 | "Returns a list of all of the keys in table." 52 | (loop for key being the hash-keys of table collecting key))) 53 | 54 | (export 55 | (define (hash-values table) 56 | "Returns a list of all of the values in table." 57 | (loop for value being the hash-values of table collecting value))) 58 | 59 | (export 60 | (define (hash->alist table) 61 | "Return an alist representation of the key/value pairs in table." 62 | (hash-map table #'cons))) 63 | 64 | (export 65 | (define (hash-for-each table proc) 66 | "Apply [proc key value] to each key/value pair in table." 67 | (maphash proc table))) 68 | 69 | (export 70 | (define (hash-remove! table key) 71 | "Removes key and associated value from table" 72 | (remhash key table))) 73 | (export 74 | (define (hash-clear! table) 75 | "Remvoes all keys and values from table." 76 | (clrhash table))) 77 | 78 | (uninstall-syntax!) 79 | -------------------------------------------------------------------------------- /src/lambda.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:schemeish.backend) 2 | 3 | (install-syntax!) 4 | 5 | (export 6 | (defmacro lambda (scm-parameters &body function-body) 7 | "Expands to a form that creates a lambda defined using the scm-parameters and function-body. 8 | See PARSE-FUNCTION and REGISTER-LAMBDA-METADATA." 9 | (lambda-form scm-parameters function-body))) 10 | 11 | (uninstall-syntax!) 12 | -------------------------------------------------------------------------------- /src/letrec.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:schemeish.backend) 2 | 3 | (install-syntax!) 4 | 5 | ;;; LET-REC 6 | 7 | (export-definition 8 | (defmacro letrec (bindings &body body) 9 | "Establish lexical bindings. All lexical variables are in scope for the binding values. 10 | Values are bound sequentially. Bindings are established for body. 11 | Body is (declarations... forms...)" 12 | (let ((declare? (lambda (form) (and (pair? form) (eq? 'cl:declare (first form)))))) 13 | (let ((declarations (takef body declare?)) 14 | (forms (dropf body declare?))) 15 | `(let ,(map #'first bindings) 16 | ,@declarations 17 | ,@(map (lambda (binding) 18 | `(setq ,(first binding) ,(second binding))) 19 | bindings) 20 | ,@forms))))) 21 | 22 | (uninstall-syntax!) 23 | -------------------------------------------------------------------------------- /src/lexical-body-definitions.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:schemeish.internals) 2 | 3 | (install-syntax!) 4 | 5 | (defvar *definition-name-field-table* (make-hash-table :weakness :key) 6 | "A hash table from function -> definition-name-field.") 7 | (defun register-definition-name-field (function name-field) 8 | (assert (functionp function)) 9 | (setf (gethash function *definition-name-field-table*) name-field)) 10 | 11 | (export 12 | (defun registered-definition-name-field (function) 13 | "Retrieve the DEFINE name-field used to define function. 14 | Returns nil if not defined using DEFINE." 15 | (gethash function *definition-name-field-table*))) 16 | 17 | (defun definition-name-field (definition) 18 | "Returns name-field of (define name-field ...)" 19 | (second definition)) 20 | (defun definition-function-body (definition) 21 | "Returns function-body of (define name-field function-body...)" 22 | (cddr definition)) 23 | (defun definition-value (definition) 24 | "Returns value of (define name-field value)" 25 | (third definition)) 26 | (defun definition-name-field->name (name-field) 27 | "Parses the definition name from the (define name-field ....)." 28 | (if (symbolp name-field) 29 | name-field 30 | (definition-name-field->name (first name-field)))) 31 | 32 | (defun documentation-string-for-definition (scm-parameters definition-name-field guard-clauses documentation-string) 33 | "Adds documentation for the definition from the scm-parameters, name-field, and guard-clauses." 34 | (let ((name (definition-name-field->name definition-name-field))) 35 | (concatenate 'string 36 | documentation-string 37 | (format nil "~&~%~%") 38 | (documentation-string-for-scm-parameters scm-parameters) 39 | (format nil "~&~%Definition Form: ~S" definition-name-field) 40 | (format nil "~&~%~%") 41 | (guard-clauses-documentation-string guard-clauses name)))) 42 | 43 | (defun register-definition-function-metadata (function scm-parameters guard-clauses documentation-source definition-name-field) 44 | "Registers metadata associated with function defined using (define (...) ...)." 45 | (let ((documentation-string (if documentation-source 46 | (documentation-string documentation-source) 47 | ""))) 48 | (setf (documentation function t) 49 | (documentation-string-for-definition scm-parameters definition-name-field guard-clauses documentation-string))) 50 | (when guard-clauses (register-guard-clauses function guard-clauses)) 51 | (when definition-name-field (register-definition-name-field function definition-name-field)) 52 | (when documentation-source (set-object-documentation-source! function documentation-source)) 53 | function) 54 | 55 | (defun definition-lambda-form (definition-name-field definition-guard-clauses scm-parameters function-body) 56 | "Return a form that creates a lambda, with metadata from a definition form. 57 | Registers the definition metadata for lambda, using definition-name-field and definition-guard-clauses 58 | instead of the parsed metadata. 59 | See PARSE-FUNCTION, REGISTER-DEFINITION-FUNCTION-METADATA, PARSED-FUNCTION->LAMBDA-FORM." 60 | (multiple-value-bind (ordinary-lambda-list ignorable-parameters body documentation-source guard-clauses declarations) 61 | (parse-function scm-parameters function-body) 62 | `(register-definition-function-metadata 63 | ,(parsed-function->lambda-form ordinary-lambda-list ignorable-parameters body guard-clauses declarations) 64 | ',scm-parameters 65 | ',definition-guard-clauses 66 | ,documentation-source 67 | ',definition-name-field))) 68 | 69 | (defun transform-lexical-body-define-pair (definition) 70 | "Transforms (define (...) . function-body) for lisp-1 style lexical-body." 71 | (let* ((definition-name-field (definition-name-field definition)) 72 | (function-body (definition-function-body definition)) 73 | (guard-clauses (multiple-value-bind (lexical-body documentation-source-form guard-clauses declarations) 74 | (parse-metadata-from-function-body function-body) 75 | (declare (ignore lexical-body documentation-source-form declarations)) 76 | guard-clauses))) 77 | (let recurse ((name-field definition-name-field) 78 | (body function-body)) 79 | (let ((name (first name-field)) 80 | (parameters (rest name-field))) 81 | (cond 82 | ((consp name) 83 | ;; Iteration: Closure definition. 84 | (recurse name (list (definition-lambda-form definition-name-field guard-clauses parameters body)))) 85 | (t 86 | ;; Base: Function definiton. 87 | (values (list name) `(setq ,name ,(definition-lambda-form definition-name-field guard-clauses parameters body))))))))) 88 | 89 | (defun transform-lexical-body2-define-pair (definition) 90 | "Transforms (define (...) . function-body) for lisp-2 style lexical-body." 91 | (let* ((definition-name-field (definition-name-field definition)) 92 | (function-body (definition-function-body definition))) 93 | (multiple-value-bind (body documentation-source guard-clauses declarations) 94 | (parse-metadata-from-function-body function-body) 95 | (let recurse ((name-field definition-name-field) 96 | (body (append declarations (enforce-guard-clauses-forms guard-clauses ()) `((lexically ,@body))))) 97 | (let ((name (first name-field)) 98 | (parameters (rest name-field))) 99 | (cond 100 | ((consp name) 101 | ;; Iteration: Closure definition. 102 | (recurse name (list (definition-lambda-form definition-name-field guard-clauses parameters body)))) 103 | (t 104 | ;; Base: Function definiton. 105 | (values (list name) 106 | `(setq ,name (register-definition-function-metadata 107 | (function ,name) 108 | ',parameters 109 | ',guard-clauses 110 | ,documentation-source 111 | ',definition-name-field)) 112 | (multiple-value-bind (ordinary-lambda-list ignorable-parameters) (scm-parameters->ordinary-lambda-list parameters) 113 | (list `(,name ,ordinary-lambda-list ,@(declare-ignorable-forms ignorable-parameters) 114 | ,@body))))))))))) 115 | 116 | (defun transform-lexical-body-define-symbol (definition) 117 | "Transforms (define symbol [documentation] value) for lisp-1 style lexical-body." 118 | (multiple-value-bind (body documentation-source) (parse-documentation-source (definition-function-body definition)) 119 | (let ((name (definition-name-field definition)) 120 | (value (first body))) 121 | (values (list name) 122 | `(setq ,name (set-object-documentation-from-documentation-source! ,value ,documentation-source)))))) 123 | 124 | (export 125 | (defun transform-lexical-body-define-symbol-or-pair (definition) 126 | "Transforms (define name-field ...) for lisp-1 style lexical-body. 127 | If name-field is a symbol the expected form is (define symbol [documentation-source] value). 128 | A let binding is created for symbol, and value is assigned to it. 129 | The documentation-source and documentation string for value is set. 130 | If name-field is a pair, the expected form is (define name-field function-body...) 131 | If name-field is a pair: ((...) . scm-parameters) 132 | A closure is created with the given scm-parameters, and define is recursively applied. 133 | E.g. (define (((nested x) y) z) function-body...) => 134 | (define (nested x) (lambda (y) (lambda (z) function-body...))) 135 | 136 | If name-field is a pair: (symbol . scm-parameters) 137 | A lambda is created with the given scm-parameters and function-body, expanded using PARSE-FUNCTION." 138 | (let ((name-field (definition-name-field definition))) 139 | (cond 140 | ((symbolp name-field) (transform-lexical-body-define-symbol definition)) 141 | (t (transform-lexical-body-define-pair definition)))))) 142 | 143 | (export 144 | (defun transform-lexical-body2-define-symbol-or-pair (definition) 145 | "Transforms (define name-field ...) for lisp-2 style lexical-body. 146 | If name-field is a symbol the expected form is (define symbol [documentation-source] value). 147 | A let binding is created for symbol, and value is assigned to it. 148 | A DEFAULT-LABELS-BINDING is created for symbol. 149 | The documentation-source and documentation string for value is set. 150 | If name-field is a pair, the expected form is (define name-field function-body...) 151 | If name-field is a pair: ((...) . scm-parameters) 152 | A closure is created with the given scm-parameters, and define is recursively applied. 153 | E.g. (define (((nested x) y) z) function-body...) => 154 | (define (nested x) (lambda (y) (lambda (z) function-body...))) 155 | If name-field is a pair: (symbol . scm-parameters) 156 | A labels binding is created with the given scm-parameters and function-body, expanded using PARSE-FUNCTION. 157 | A let binding is created for symbol, with #'symbol assigned to it. 158 | 159 | See also: LEXICALLY, PARSE-FUNCTION." 160 | (let ((name-field (definition-name-field definition))) 161 | (cond 162 | ((symbolp name-field) 163 | (multiple-value-bind (names set-form) (transform-lexical-body-define-symbol definition) 164 | (values names set-form (mapcar #'default-labels-binding names)))) 165 | (t (transform-lexical-body2-define-pair definition)))))) 166 | 167 | (export 168 | (defun transform-lexical-body-define-values (definition) 169 | "Transforms (define-values name-or-names values-form) for lisp-1 style lexical-body. 170 | If name-or-names is a symbol: 171 | A let binding is created, and the (multiple-values-list values-form) is assigned to it. 172 | If name-or-names is a list of symbols: 173 | A let binding is created for each symbol, and they are bound using multiple-value-setq. 174 | See also: LEXICALLY." 175 | (let ((name-field (definition-name-field definition)) 176 | (values-form (definition-value definition))) 177 | (flet ((ignore? (symbol) (string= (symbol-name symbol) "_"))) 178 | (cond 179 | ((symbolp name-field) (values (list name-field) `(setq ,name-field (multiple-value-list ,values-form)))) 180 | (t 181 | (let iter ((given-names name-field) 182 | (names ()) 183 | (vars ()) 184 | (ignored-names ())) 185 | (cond 186 | ((null given-names) 187 | (values (nreverse names) 188 | `(cl:let ,ignored-names 189 | (multiple-value-setq ,(nreverse vars) ,values-form)))) 190 | (t (let ((name (first given-names)) 191 | (rest-names (rest given-names))) 192 | (if (ignore? name) 193 | (let ((var (unique-symbol 'ignore))) 194 | (iter rest-names names (cons var vars) (cons var ignored-names))) 195 | (iter rest-names (cons name names) (cons name vars) ignored-names)))))))))))) 196 | 197 | (export 198 | (defun transform-lexical-body-define-destructuring (definition) 199 | "Transforms (define-destructuring destructuring-lambda-list expression) for lisp-1 style lexical-body. 200 | Uses DESTRUCTURING-BIND to destructure expression and creates bindings for each name in destructuring-lambda-list." 201 | (let* ((lambda-list (definition-name-field definition)) 202 | (names (destructuring-lambda-list-parameter-names lambda-list)) 203 | (expression (definition-value definition))) 204 | (transform-lexical-body-define-values `(define-values ,names (destructuring-bind ,lambda-list ,expression (values ,@names))))))) 205 | (export 206 | (defun transform-lexical-body-define-unique-symbols (definition) 207 | (let ((names (rest definition))) 208 | (values names `(progn ,@(mapcar (cl:lambda (name) 209 | `(setq ,name (unique-symbol ',name))) 210 | names)))))) 211 | 212 | ;; Register define and define-values 213 | ;; Lisp-1 style Lexical body definitions 214 | (register-lexical-body-definition 'define #'transform-lexical-body-define-symbol-or-pair) 215 | (register-lexical-body-definition 'define-values #'transform-lexical-body-define-values) 216 | (register-lexical-body-definition 'def-values #'transform-lexical-body-define-values) 217 | (register-lexical-body-definition 'define-destructuring #'transform-lexical-body-define-destructuring) 218 | (register-lexical-body-definition 'def-destructuring #'transform-lexical-body-define-destructuring) 219 | (register-lexical-body-definition 'define-unique-symbols #'transform-lexical-body-define-unique-symbols) 220 | (register-lexical-body-definition 'def-unique-symbols #'transform-lexical-body-define-unique-symbols) 221 | (register-lexical-body-definition 'def #'transform-lexical-body-define-symbol-or-pair) 222 | 223 | ;; Lisp-2 style lexical body definitions 224 | (register-lexical-body2-definition 'define #'transform-lexical-body2-define-symbol-or-pair) 225 | (register-lexical-body2-definition 'def #'transform-lexical-body2-define-symbol-or-pair) 226 | (export '(def define-values def-values define-destructuring def-destructuring define-unique-symbols def-unique-symbols)) 227 | 228 | #; 229 | (assert (equal (lexically 230 | (define-destructuring (&whole whole r1 r2 231 | &optional (o1 3 o1-provided?) 232 | &body body) 233 | '(r1 r2 o1 :k1 k1)) 234 | (list whole o1-provided?)) 235 | '((R1 R2 O1 :K1 K1) T))) 236 | 237 | (uninstall-syntax!) 238 | -------------------------------------------------------------------------------- /src/lexical-body.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:schemeish.internals) 2 | 3 | (install-syntax!) 4 | 5 | (defvar *lexical-body-definition-table* (make-hash-table) 6 | "Table from SYMBOL -> TRANSFORM for LISP-1 Lexical-Body transformations.") 7 | (defvar *lexical-body2-definition-table* (make-hash-table) 8 | "Table from SYMBOL -> TRANSFORM for LISP-2 Lexical-Body transformations.") 9 | 10 | (export 11 | (defun register-lexical-body-definition (symbol transform) 12 | "Registers transform for lisp-1 lexical-body tranformations. 13 | Transform is a procedure s.t. (transform definition-form) => (values names set-form)" 14 | (setf (gethash symbol *lexical-body-definition-table*) transform))) 15 | (export 16 | (defun register-lexical-body2-definition (symbol transform) 17 | "Registers transform for lisp-2 lexical-body transformations. 18 | Transform is a procedure s.t. (transform definition-form) => (values names set-form labels-bindings)" 19 | (setf (gethash symbol *lexical-body2-definition-table*) transform))) 20 | 21 | (export 22 | (defun unregister-lexical-body-definition (symbol) 23 | "Unregisters transform for lisp-1 lexical-body tranformations." 24 | (remhash symbol *lexical-body-definition-table*))) 25 | (export 26 | (defun unregister-lexical-body2-definition (symbol) 27 | "Unregisters transform for lisp-2 lexical-body transformations." 28 | (remhash symbol *lexical-body2-definition-table*))) 29 | 30 | (export 31 | (defun lexical-body-definition? (form) 32 | "True if FORM is a registered lisp-1 style lexical-body definition." 33 | (and (consp form) 34 | (gethash (first form) *lexical-body-definition-table* nil)))) 35 | (export 36 | (defun lexical-body2-definition? (form) 37 | "True if FORM is a registered lisp-2 style lexical-body definition." 38 | (and (consp form) 39 | (gethash (first form) *lexical-body2-definition-table* nil)))) 40 | 41 | (defun transform-lexical-body-definition (form) 42 | "Transform FORM if FORM is a registered lisp-1 style lexical-body definition. 43 | Returns (values names set-form)" 44 | [(gethash (first form) *lexical-body-definition-table*) form]) 45 | (defun transform-lexical-body2-definition (form) 46 | "Transform FORM if FORM is a registered lisp-2 style lexical-body definition. 47 | Returns (values variable-names variables-set-form labels-bindings)" 48 | [(gethash (first form) *lexical-body2-definition-table*) form]) 49 | 50 | (export 51 | (defun lexical-body-definition-documentations () 52 | "Returns a list of (symbol documentation) for all currently registered lisp-1 style lexical-body definitions." 53 | (let ((result ())) 54 | (maphash (cl:lambda (symbol transform) 55 | (push (cons symbol (documentation transform t)) result)) 56 | *lexical-body-definition-table*) 57 | result))) 58 | (export 59 | (defun lexical-body2-definition-documentations () 60 | "Returns a list of (symbol documentation-source) for all currently registered lisp-2 style lexical-body definitions. 61 | Includes results for lisp-1 style lexical-body definitions if there are no applicable transforms for lisp-2 style lexical-body." 62 | (let ((result ()) 63 | (body1-result (lexical-body-definition-documentations))) 64 | (maphash (cl:lambda (symbol transform) 65 | (push (cons symbol (documentation transform t)) result)) 66 | *lexical-body2-definition-table*) 67 | (union result (set-difference body1-result result :key #'first))))) 68 | 69 | (defun parse-lexical-body-definitions (lexical-body) 70 | "Returns (values definitions body)" 71 | (splitf lexical-body #'lexical-body-definition?)) 72 | (defun parse-lexical-body2-definitions (lexical-body) 73 | "Returns (values definitions body). Takes both lisp-1 and lisp-2 definitions." 74 | (let ((definition? (cl:lambda (definition) 75 | (or (lexical-body2-definition? definition) 76 | (lexical-body-definition? definition))))) 77 | (splitf lexical-body definition?))) 78 | 79 | (defun collect-lexical-body-definitions-names-and-set-forms (definitions) 80 | "Returns (values names set-forms) for lisp-1 style lexical-body." 81 | (labels ((iter (definitions names set-forms) 82 | (cond 83 | ((null definitions) (values names (nreverse set-forms))) 84 | (t (multiple-value-bind (new-names set-form) (transform-lexical-body-definition (first definitions)) 85 | (iter (rest definitions) (append names new-names) (cons set-form set-forms))))))) 86 | (iter definitions () ()))) 87 | 88 | (defun default-labels-binding (name) 89 | "Return a binding with the given name for LABELS which just applies the lexical variable name to its arguments." 90 | (let ((rest (unique-symbol 'arguments))) 91 | `(,name (&rest ,rest) (apply ,name ,rest)))) 92 | 93 | (defun collect-lexical-body2-definitions-names-and-set-forms (definitions) 94 | "Returns (values names set-forms labels-bindings) for SCHEMEISH (lisp-2) lexical-body. 95 | If there is no appliciable transformer for a lisp-2 definition, a lisp-1 definition will 96 | be used with a DEFAULT-LABELS-BINDING." 97 | (labels ((iter (definitions names set-forms labels-bindings) 98 | (cond 99 | ((null definitions) (values names (nreverse set-forms) labels-bindings)) 100 | ((lexical-body2-definition? (first definitions)) 101 | (multiple-value-bind (new-names set-form new-labels-bindings) (transform-lexical-body2-definition (first definitions)) 102 | (unless (= (length new-names) (length new-labels-bindings)) 103 | (error "Bad expansion for lexical-body-definition2: ~S. Expected the same number of names ~S as labels-bindings ~S." 104 | (first definitions) 105 | new-names 106 | new-labels-bindings)) 107 | (iter (rest definitions) 108 | (append names new-names) 109 | (cons set-form set-forms) 110 | (append labels-bindings new-labels-bindings)))) 111 | (t 112 | ;; Definition is a lexical-body (lisp-1) definition, not a lexical-body2 (lisp-2) definition 113 | ;; Generate default labels bindings (just apply the variable to provided arguments) 114 | (multiple-value-bind (new-names set-form) (transform-lexical-body-definition (first definitions)) 115 | (iter (rest definitions) 116 | (append names new-names) 117 | (cons set-form set-forms) 118 | (append labels-bindings (mapcar #'default-labels-binding new-names)))))))) 119 | (iter definitions () () ()))) 120 | 121 | (export 122 | (defun parse-lexical-body (body) 123 | "Returns (values forms declarations names set-forms) for lisp-1 lexical-body. 124 | A lexical body is (definitions... declarations... forms...)" 125 | (multiple-value-bind (definitions body) (parse-lexical-body-definitions body) 126 | (multiple-value-bind (names set-forms) (collect-lexical-body-definitions-names-and-set-forms definitions) 127 | (multiple-value-bind (declarations body) (parse-declarations body) 128 | (values body declarations names set-forms)))))) 129 | (defun parse-lexical-body2 (body) 130 | "Returns (values declarations body names set-forms labels-bindings) for SCHEMEISH (lisp-2) lexical-body. 131 | A lexical body is (definitions... declarations... forms...)" 132 | (multiple-value-bind (definitions body) (parse-lexical-body2-definitions body) 133 | (multiple-value-bind (declarations body) (parse-declarations body) 134 | (multiple-value-bind (names set-forms labels-bindings) (collect-lexical-body2-definitions-names-and-set-forms definitions) 135 | (values body declarations names set-forms labels-bindings))))) 136 | 137 | (export 138 | (defun lexical-body2-form (body) 139 | "Expands LISP-2 lexical-body definitions in BODY. A lexical-body is (definitions... declarations... forms...)" 140 | (multiple-value-bind (body declarations names set-forms labels-bindings) (parse-lexical-body2 body) 141 | `(cl:let ,names 142 | (declare (ignorable ,@names)) 143 | (cl:labels ,labels-bindings 144 | ;; Declare local function bindings ignorable. 145 | (declare (ignorable ,@(mapcar (cl:lambda (name) `(function ,name)) names))) 146 | ,@declarations 147 | ,@set-forms 148 | ,@body))))) 149 | 150 | (export 151 | (defmacro lexically (&body lexical-body) 152 | "Expands lisp-2 style lexical-body definitions in body. 153 | A lexical-body is (lexical-body-definitions... declarations... forms...). 154 | If definition is LISP-2 it is transformed and its labels-bindings are used. 155 | If definition is not LISP-2, but is LISP-1 it is transformed and a DEFAULT-LABELS-BINDING is used. 156 | Creates mutually-recursive variable and function bindings for all definitions. 157 | See REGISTER-LEXICAL-BODY-DEFINITION and REGISTER-LEXICAL-BODY2-DEFINITION for more information about how 158 | to extend LEXICALLY. 159 | See the results of evaluating (lexical-body2-definition-documentations) and (lexical-body-definition-documentations) 160 | For documentation on the currently registered definition transformations." 161 | (lexical-body2-form lexical-body))) 162 | 163 | (lexical-body2-definition-documentations) 164 | 165 | 166 | (uninstall-syntax!) 167 | -------------------------------------------------------------------------------- /src/lists.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:schemeish.backend) 2 | 3 | (install-syntax!) 4 | 5 | ;;; Lists 6 | (export 7 | (define (map function list &rest more-lists) 8 | (apply #'mapcar function list more-lists))) 9 | 10 | (export 11 | (define (append* lists) 12 | (apply #'append lists))) 13 | 14 | (export 15 | (define empty? #'null)) 16 | 17 | (export 18 | (define (for-each proc . lists) 19 | "Apply proc to each element of lists. Arity of proc should match the number of lists." 20 | (let rec ((lists lists)) 21 | (unless (member nil lists) 22 | (apply proc (map 'first lists)) 23 | (rec (map 'rest lists)))))) 24 | 25 | (assert (equal? 26 | (with-output-to-string (s) 27 | (for-each (lambda (x y) (format s "~S" (list x y))) 28 | '(a b c) 29 | '(1 2 3))) 30 | "(A 1)(B 2)(C 3)")) 31 | 32 | (export 33 | (define (repeat fn count) 34 | "Repeatedly call fn count times." 35 | (assert (not (negative? count))) 36 | (for-each (lambda (_) [fn]) (range count)))) 37 | 38 | (export 39 | (define (filter predicate list) 40 | "Keep elements of list that satisfy predicate." 41 | (remove-if-not predicate list))) 42 | 43 | (export 44 | (define (filter-not pred list) 45 | "Returns a list of elements that don't satisfy predicate pred." 46 | (filter (lambda (x) (not [pred x])) list))) 47 | 48 | (export 49 | (define (partition pred list) 50 | "Returns (list elements-satisfying-pred elements-not-satisfying-pred)" 51 | (list (filter pred list) 52 | (filter-not pred list)))) 53 | 54 | (assert (equal (partition 'even? '(1 2 3 4 5 6)) 55 | '((2 4 6) (1 3 5)))) 56 | 57 | (export 58 | (define (filter-map proc . lists) 59 | "Remove nil from the result of mapping proc over lists." 60 | (remove nil (apply 'map proc lists)))) 61 | 62 | (export 63 | (define (range end (start 0) (step 1)) 64 | "Return a list of elements from [start,end) using step as the stepsize." 65 | (if (<= start end) 66 | (loop for i from start below end by step collecting i) 67 | (loop for i from start downto end by step collecting i)))) 68 | 69 | 70 | (export 71 | (define (append-map proc . lists) 72 | "Append the results of mapping procedure across lists." 73 | (append* (apply 'map proc lists)))) 74 | 75 | (export 76 | (define (map-successive n f list) 77 | "Maps f over successive groups of size n in list." 78 | (let rec ((list list) 79 | (length (length list)) 80 | (result ())) 81 | (cond 82 | ((< length n) (nreverse result)) 83 | (t (rec (rest list) 84 | (1- length) 85 | (cons (apply f (subseq list 0 n)) result))))))) 86 | 87 | (assert (equal? (map-successive 3 'list (list 1 2 3 4)) 88 | '((1 2 3) (2 3 4)))) 89 | 90 | (export 91 | (define pair? "T if datum is a cons." #'consp)) 92 | (export 93 | (define null? "T if datum is nil." #'null)) 94 | (export 95 | (define list? "Alias for (listp datum)." #'listp)) 96 | 97 | (export 98 | (define (list-type list) 99 | "Returns one of (:proper :cyclic :dotted (values :dotted :cons))" 100 | #g((list? list)) 101 | ;; Field is a list, list*, cons, or a cycle 102 | (let recurse ((xs list) 103 | (visited ()) 104 | (result ())) 105 | (cond 106 | ((empty? xs) :proper) 107 | ((member xs visited) :cyclic) 108 | ((pair? xs) 109 | ;; In the middle of the list, keep looking. 110 | (recurse (rest xs) (cons xs visited) (cons (first xs) result))) 111 | (t 112 | (cond 113 | ;; Dotted-lists 114 | ((pair? (rest list)) :dotted) 115 | (t (values :dotted :cons)))))))) 116 | 117 | (export 118 | (define (proper-list? list) 119 | (and (list? list) 120 | (eq? :proper (list-type list))))) 121 | 122 | 123 | (export 124 | (define (list-ref list pos) 125 | "Return the value of list at pos." 126 | (nth pos list))) 127 | 128 | (export 129 | (define (list-tail list pos) 130 | "Return the sublist of list starting at pos." 131 | (nthcdr pos list))) 132 | 133 | (export 134 | (define (foldl proc init . lists) 135 | "Fold (proc e1 e2 ... result) across lists starting from the start of the lists." 136 | (let rec ((result init) 137 | (lists lists)) 138 | (if (or (empty? lists) (member nil lists)) 139 | result 140 | (rec (apply proc (append (map #'first lists) (list result))) 141 | (map #'rest lists)))))) 142 | 143 | (assert (equal (foldl 'cons () '(1 2 3 4)) 144 | '(4 3 2 1))) 145 | 146 | (assert (= (foldl (lambda (a b result) 147 | (* result (- a b))) 148 | 1 149 | '(1 2 3) 150 | '(4 5 6)) 151 | -27)) 152 | 153 | (export 154 | (define (foldr proc init . lists) 155 | "Fold (proc e1 e2 ... result) across lists starting from the end of the lists." 156 | (let rec ((result init) 157 | (lists (map 'reverse lists))) 158 | (if (or (empty? lists) (member nil lists)) 159 | result 160 | (rec (apply proc (append (map #'first lists) (list result))) 161 | (map #'rest lists)))))) 162 | 163 | (assert (equal (foldr 'cons '() '(1 2 3 4)) 164 | '(1 2 3 4))) 165 | (assert (equal (foldr (lambda (v l) (cons (1+ v) l)) '() '(1 2 3 4)) 166 | '(2 3 4 5))) 167 | 168 | (export 169 | (define (andmap proc . lists) 170 | "Return the last non-nil result of mapping proc across lists, or nil if some result is nil." 171 | (let rec ((result t) 172 | (lists lists)) 173 | (if (or (not result) (member nil lists)) 174 | result 175 | (rec (apply proc (map 'first lists)) 176 | (map 'rest lists)))))) 177 | 178 | (assert (andmap 'positive? '(1 2 3))) 179 | ;; (andmap 'positive? '(1 2 a)) => error 180 | (assert (not (andmap 'positive? '(1 -2 a)))) 181 | (assert (= 9 (andmap '+ '(1 2 3) '(4 5 6)))) 182 | 183 | (export 184 | (define (ormap proc . lists) 185 | "Return the first non-nil result of mapping proc across lists." 186 | (let rec ((result ()) 187 | (lists lists)) 188 | (if (or result (member nil lists)) 189 | result 190 | (rec (apply proc (map 'first lists)) 191 | (map 'rest lists)))))) 192 | 193 | 194 | (assert (ormap 'eq? '(a b c) '(a b c))) 195 | (assert (ormap 'positive? '(1 2 a))) 196 | (assert (= 5 (ormap '+ '(1 2 3) '(4 5 6)))) 197 | 198 | 199 | (export 200 | (define (remq v list) 201 | "Remove using eq? as a test." 202 | (remove v list :test #'eq))) 203 | 204 | (export 205 | (define (remove* v-list list (test #'equal?)) 206 | "Removes all elements in v-list from list." 207 | (foldl (lambda (v result) (remove v result :test test)) list v-list))) 208 | 209 | (assert (equal 210 | (remove* (list 1 2) (list 1 2 3 2 4 5 2)) 211 | '(3 4 5))) 212 | 213 | (export 214 | (define (remq* v-list list) (remove* v-list list #'eq?))) 215 | 216 | (export 217 | (define (sort list less-than? (:extract-key #'identity)) 218 | "Returns a sorted list." 219 | (cl:sort (copy-list list) less-than? :key extract-key))) 220 | 221 | (assert (equal (let* ((original-list '(1 3 4 2)) 222 | (sorted-list (sort original-list '<))) 223 | (assert (equal '(1 3 4 2) original-list)) 224 | sorted-list) 225 | '(1 2 3 4))) 226 | 227 | 228 | (export 229 | (define (memf proc list) 230 | "Returns the first sublist of list whose first element satisfies predicate proc." 231 | (let rec ((list list)) 232 | (if (or (null? list) [proc (first list)]) 233 | list 234 | (rec (rest list)))))) 235 | 236 | (assert (equal (memf (lambda (arg) (> arg 9)) '(7 8 9 10 11)) 237 | '(10 11))) 238 | 239 | (export 240 | (define (findf proc list) 241 | "Finds the first element in list that satisfies predicate proc." 242 | (let ((found (memf proc list))) 243 | (if (list? found) 244 | (first found) 245 | ())))) 246 | 247 | (assert (= (findf (lambda (arg) (> arg 9)) '(7 8 9 10 11)) 248 | 10)) 249 | 250 | (export 251 | (define (list-update list pos updater) 252 | "Returns a list with (updater value) to the value at pos in list." 253 | (let rec ((list list) 254 | (current-pos 0) 255 | (result '())) 256 | (cond 257 | ((null? list) (nreverse result)) 258 | (t 259 | (rec (rest list) 260 | (1+ current-pos) 261 | (cons (let ((x (first list))) 262 | (if (= current-pos pos) [updater x] x)) 263 | result))))))) 264 | 265 | (assert (equal (list-update '(zero one two) 1 'symbol->string) 266 | '(ZERO "ONE" TWO))) 267 | 268 | 269 | (export 270 | (define (list-set list pos value) 271 | "Return a list with the value at pos replaced." 272 | (let rec ((list list) 273 | (current-pos 0) 274 | (result '())) 275 | (cond 276 | ((null? list) (nreverse result)) 277 | (t 278 | (rec (rest list) 279 | (1+ current-pos) 280 | (cons (let ((x (first list))) 281 | (if (= current-pos pos) value x)) 282 | result))))))) 283 | 284 | (assert (equal (list-set '(zero one two) 2 "two") 285 | '(zero one "two"))) 286 | 287 | (export 288 | (define (take list n) 289 | "Takes the first n elements from list" 290 | (let rec ((list list) 291 | (current-pos 0) 292 | (result '())) 293 | (if (or (= n current-pos) (empty? list)) 294 | (nreverse result) 295 | (rec (rest list) 296 | (1+ current-pos) 297 | (cons (first list) result)))))) 298 | 299 | (assert (equal (take '(1 2 3 4 5) 2) 300 | '(1 2))) 301 | 302 | (export 303 | (define (drop list n) 304 | "Drops the first n elements from list" 305 | (list-tail list n))) 306 | 307 | (export 308 | (define (split-at list pos) 309 | "Returns (list (take list pos) (drop list pos))" 310 | (list (take list pos) (drop list pos)))) 311 | 312 | 313 | (export 314 | (define (intersperse element list) 315 | "Return list with element placed between every other element." 316 | (define (intersperse-loop list result) 317 | (cond 318 | ((empty? list) (nreverse result)) 319 | (t (intersperse-loop (rest list) 320 | (list* (first list) element result))))) 321 | 322 | (assert (list? list)) 323 | (cond 324 | ((empty? list) ()) 325 | (t 326 | (cons (first list) (intersperse-loop (rest list) ())))))) 327 | 328 | (assert (equal? (intersperse :a ()) 329 | ())) 330 | (assert (equal? (intersperse :a '(:b)) 331 | '(:b))) 332 | (assert (equal? (intersperse :b '(:a :c)) 333 | '(:a :b :c))) 334 | (assert (equal? (intersperse :i '(:e :e :o)) 335 | '(:e :i :e :i :o))) 336 | 337 | (uninstall-syntax!) 338 | -------------------------------------------------------------------------------- /src/logic.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:schemeish.backend) 2 | 3 | (install-syntax!) 4 | 5 | ;;; Logic 6 | (export 7 | (define eq? #'eq)) 8 | 9 | (defgeneric equal? (object1 object2) 10 | (:documentation "Provides a generic interface to EQUAL.")) 11 | (defmethod equal? (object1 object2) (equal object1 object2)) 12 | (export 'equal?) 13 | 14 | (export 15 | (defmacro nand (&rest expressions) 16 | "The same as (not (and expressions...))" 17 | `(not (and ,@expressions)))) 18 | 19 | (export 20 | (defmacro nor (&rest expressions) 21 | "The same as (not (or expressions...))" 22 | `(not (or ,@expressions)))) 23 | 24 | (export 25 | (define (xor b1 b2) 26 | "Logical xor of booleans b1 and b2." 27 | (or (and b1 (not b2)) 28 | (and b2 (not b1))))) 29 | 30 | (uninstall-syntax!) 31 | -------------------------------------------------------------------------------- /src/markup.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:schemeish.internals) 2 | 3 | ;; TODO: Use these to make some better documentation 4 | 5 | (defclass markup-object () ()) 6 | (defun markup-object? (object) 7 | (typep object 'markup-object)) 8 | 9 | (defclass markup-ordered-list (markup-object) 10 | ((elements :initarg :elements 11 | :reader markup-ordered-list-elements))) 12 | (defun markup-ordered-list (&rest elements) 13 | "Elements should satisfy markup-object?" 14 | (assert (every #'markup-object? elements)) 15 | (make-instance 'markup-ordered-list :elements elements)) 16 | 17 | 18 | (defclass markup-unordered-list (markup-object) 19 | ((elements :initarg :elements 20 | :reader markup-unordered-list-elements))) 21 | (defun markup-unordered-list (&rest elements) 22 | "Elements should satisfy markup-object?" 23 | (assert (every #'markup-object? elements)) 24 | (make-instance 'markup-unordered-list :elements elements)) 25 | 26 | (defclass markup-code (markup-object) 27 | ((inline-text :initarg :inline-text 28 | :reader markup-code-inline-text))) 29 | (defun markup-code (inline-text) 30 | "Inline-text should satisfy INLINE-TEXT?" 31 | (assert (inline-text? inline-text)) 32 | (make-instance 'markup-code :inline-text inline-text)) 33 | 34 | (defclass markup-code-block (markup-object) 35 | ((preformatted-text :initarg :preformatted-text 36 | :reader markup-code-block-preformatted-text))) 37 | (defun markup-code-block (preformatted-text) 38 | "Preformatted-text should be a string." 39 | (assert (stringp preformatted-text)) 40 | (make-instance 'markup-code-block :preformatted-text preformatted-text)) 41 | 42 | (defclass markup-horizontal-bar (markup-object) ()) 43 | (defun markup-horizontal-bar () 44 | (make-instance 'markup-horizontal-bar)) 45 | 46 | (defclass markup-link (markup-object) 47 | ((url :initarg :url 48 | :reader markup-link-url) 49 | (inline-text :initarg :inline-text 50 | :reader markup-link-inline-text))) 51 | (defun markup-link (url &optional inline-text) 52 | "Construct an inline-markup object which represents a link to a url. [link text](url) or 53 | URL and INLINE-TEXT (if provided) must satisfy INLINE-TEXT?." 54 | (assert (inline-text? url)) 55 | (assert (or (null inline-text) (inline-text? inline-text))) 56 | (make-instance 'markup-link :url url :inline-text inline-text)) 57 | 58 | 59 | (defclass markup-seq (markup-object) 60 | ((markups :initarg :markups 61 | :reader markup-seq-markups))) 62 | 63 | (defun markup-seq (&rest markups) 64 | "Return a sequence of markups. Inline markups will be rendered together directly or separated by a newline. 65 | Non-inline markups will be rendered with a fresh line before/after." 66 | (assert (every #'markup-object? markups)) 67 | (make-instance 'markup-seq :markups markups)) 68 | 69 | 70 | (defclass markup-table (markup-object) 71 | ((column-headers :initarg :column-headers 72 | :reader markup-table-column-headers) 73 | (rows :initarg :rows 74 | :reader markup-table-rows) 75 | (column-alignments :initarg :column-alignments 76 | :reader markup-table-column-alignments))) 77 | 78 | (defun markup-table-column-alignment? (object) 79 | "True if object is a valid markup-table column-alignment: one of '(:LEFT :RIGHT :CENTER)." 80 | (member object '(:left :right :center))) 81 | 82 | (defun markup-table (column-headers rows &optional (column-alignments (mapcar (constantly :left) column-headers))) 83 | "Create a table given a list of column-headers and a list of rows. Each row must be a list 84 | with the same number of elements as column-headers. Column-alignments must also 85 | be the same length as column-headers, and each alignment should be one of '(:LEFT :RIGHT :CENTER). 86 | 87 | | Header 1 | Header 2 | 88 | | -------- | -------- | 89 | | Row 1 C1 | Row 1 C2 | 90 | | Row 2 C1 | Row 2 C2 |" 91 | (assert (every #'markup-table-column-alignment? column-alignments)) 92 | (assert (every #'markup-object? column-headers)) 93 | (assert (every (lambda (row) (every #'markup-object? row)) rows)) 94 | 95 | (make-instance 'markup-table :column-alignments column-alignments :rows rows :column-headers column-headers)) 96 | 97 | ;; Hyperspec Style documentation 98 | 99 | (defstruct function-reference symbol) 100 | (defstruct variable-reference symbol) 101 | (defstruct package-reference symbol) 102 | (defstruct type-reference symbol) 103 | 104 | (defun function-reference (symbol) 105 | (make-function-reference :symbol symbol)) 106 | (defun variable-reference (symbol) 107 | (make-variable-reference :symbol symbol)) 108 | (defun package-reference (symbol) 109 | (make-package-reference :symbol symbol)) 110 | (defun type-reference (symbol) 111 | (make-type-reference :symbol symbol)) 112 | 113 | (defstruct function-style-doc 114 | function-type 115 | name 116 | syntax 117 | arguments-and-values 118 | description 119 | examples 120 | side-effects 121 | affected-by 122 | exceptional-situations 123 | see-also 124 | notes) 125 | 126 | (defun function-doc (&key name 127 | syntax 128 | arguments-and-values 129 | description 130 | examples 131 | side-effects 132 | affected-by 133 | exceptional-situations 134 | see-also 135 | notes) 136 | (make-function-style-doc :function-type :function 137 | :name name 138 | :syntax syntax 139 | :arguments-and-values arguments-and-values 140 | :description description 141 | :examples examples 142 | :side-effects side-effects 143 | :affected-by affected-by 144 | :exceptional-situations exceptional-situations 145 | :see-also see-also 146 | :notes notes)) 147 | (defun symbol-doc (&key name 148 | syntax 149 | arguments-and-values 150 | description 151 | examples 152 | side-effects 153 | affected-by 154 | exceptional-situations 155 | see-also 156 | notes) 157 | (make-function-style-doc :function-type :symbol 158 | :name name 159 | :syntax syntax 160 | :arguments-and-values arguments-and-values 161 | :description description 162 | :examples examples 163 | :side-effects side-effects 164 | :affected-by affected-by 165 | :exceptional-situations exceptional-situations 166 | :see-also see-also 167 | :notes notes)) 168 | (defun macro-doc (&key name 169 | syntax 170 | arguments-and-values 171 | description 172 | examples 173 | side-effects 174 | affected-by 175 | exceptional-situations 176 | see-also 177 | notes) 178 | (make-function-style-doc :function-type :macro 179 | :name name 180 | :syntax syntax 181 | :arguments-and-values arguments-and-values 182 | :description description 183 | :examples examples 184 | :side-effects side-effects 185 | :affected-by affected-by 186 | :exceptional-situations exceptional-situations 187 | :see-also see-also 188 | :notes notes)) 189 | 190 | (defstruct variable-doc 191 | name 192 | value-type 193 | initial-value 194 | description 195 | examples 196 | affected-by 197 | see-also 198 | notes) 199 | 200 | (defstruct type-doc 201 | name 202 | class-precedence-list 203 | description 204 | see-also) 205 | -------------------------------------------------------------------------------- /src/named-let.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:schemeish.internals) 2 | 3 | ;; Named let. 4 | (defmacro let (&whole whole &rest rest) 5 | "Extends CL:let by allowing for named let recursive forms. E.g. 6 | (let rec ((n 10) 7 | (result '())) 8 | (if (= n 0) 9 | result 10 | (rec (1- n) (cons n result)))) 11 | ;; => '(1 2 3 4 5 6 7 8 9 10)" 12 | (declare (ignore rest)) 13 | (if (and (not (null (second whole))) (symbolp (second whole))) 14 | (destructuring-bind (name bindings &rest body) (rest whole) 15 | `(labels ((,name ,(mapcar #'car bindings) 16 | ,@body)) 17 | (,name ,@(mapcar #'second bindings)))) 18 | `(cl:let ,@(rest whole)))) 19 | (export 'let) 20 | -------------------------------------------------------------------------------- /src/numbers.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:schemeish.backend) 2 | 3 | (install-syntax!) 4 | 5 | (export 6 | (define even? #'evenp)) 7 | (export 8 | (define odd? #'oddp)) 9 | (export 10 | (define zero? #'zerop)) 11 | 12 | (export 13 | (define (quotient n m) 14 | "Trunacate n/m" 15 | (truncate n m))) 16 | 17 | (export 18 | (define (number->string number (radix 10)) 19 | "Convert number to string using radix as the base." 20 | (let ((*print-base* radix)) 21 | (format nil "~S" number)))) 22 | 23 | (export 24 | (define (degrees->radians deg) 25 | "convert degrees to radians" 26 | (/ (* pi deg) 180))) 27 | (export 28 | (define (radians->degrees rads) 29 | "convert radians to degrees." 30 | (/ (* 180 rads) pi))) 31 | 32 | (export 33 | (define (sqr n) 34 | "n*n" 35 | (* n n))) 36 | 37 | (export 38 | (define (sgn x) 39 | "Return the sign of x: 1,-1, or 0" 40 | (cond 41 | ((positive? x) 1) 42 | ((negative? x) -1) 43 | ((zero? x) 0)))) 44 | 45 | (export 46 | (define number? #'numberp)) 47 | 48 | 49 | (export 50 | (define negative? #'minusp)) 51 | (export 52 | (define positive? #'plusp)) 53 | 54 | (uninstall-syntax!) 55 | -------------------------------------------------------------------------------- /src/output.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:schemeish.backend) 2 | 3 | (install-syntax!) 4 | 5 | ;;; Output 6 | 7 | (export 8 | (define (newline (out *standard-output*)) (format out "~%"))) 9 | (export 10 | (define (display datum (out *standard-output*)) (format out "~A" datum))) 11 | (export 12 | (define (displayln datum (out *standard-output*)) 13 | (display datum out) 14 | (newline out))) 15 | 16 | (uninstall-syntax!) 17 | -------------------------------------------------------------------------------- /src/procedures.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:schemeish.backend) 2 | 3 | (install-syntax!) 4 | 5 | ;;; Procedures 6 | 7 | (export 8 | (define procedure? #'functionp)) 9 | 10 | (export 11 | (define (compose* procs) 12 | "Function compositions. Mulitple values of one function are used as arguments to the next." 13 | (foldr (lambda (proc result) 14 | (lambda args 15 | (multiple-value-call proc (apply result args)))) 16 | (lambda args (values-list args)) 17 | procs))) 18 | 19 | (export 20 | (define (compose . procs) 21 | "Function compositions. Mulitple values of one function are used as arguments to the next." 22 | (compose* procs))) 23 | 24 | 25 | (assert (equal (multiple-value-list [(compose) :x :y :z]) 26 | '(:x :y :z))) 27 | 28 | (assert (equal [(compose (lambda (x y z) (list 'f x y z))) 'x 'y 'z] 29 | '(f x y z))) 30 | 31 | (assert (equal 32 | [(compose (lambda (a b c) (list 'f a b c)) 33 | (lambda (x y) (values (list 'g x) (list 'g y) (list 'g 'c)))) 34 | 'x 'y] 35 | 36 | '(f (g x) (g y) (g c)))) 37 | 38 | 39 | 40 | (define (remove-indices indices list) 41 | "Remove all 0-based indices from list." 42 | (nreverse (foldl (lambda (arg index result) 43 | (if (member index indices) 44 | result 45 | (cons arg result))) 46 | () 47 | list 48 | (range (length list))))) 49 | 50 | (assert (equal (remove-indices '(1 3) '(a b c d e f)) '(a c e f))) 51 | 52 | (export 53 | (define ((ignore-args . indices) f) 54 | "Return a function, which when applied to a function F ignores positional arguments matching the 0-based indices." 55 | (lambda args 56 | (apply f (remove-indices indices args))))) 57 | 58 | (assert (equal [[(ignore-args 1 4) (lambda (a c d) (list a c d))] 59 | :a :b :c :d :e] 60 | '(:A :C :D))) 61 | 62 | 63 | (export 64 | (define (lcurry proc . left-args) 65 | "Return a procedure waiting for the right-args." 66 | (lambda right-args 67 | (apply proc (append left-args right-args))))) 68 | 69 | (assert (= [(lcurry '- 5 4) 3] 70 | (- 5 4 3))) 71 | 72 | (export 73 | (define (rcurry proc . right-args) 74 | "Return a procedure waiting the left-args." 75 | (lambda left-args 76 | (apply proc (append left-args right-args))))) 77 | 78 | (assert (= [(rcurry '- 4 3) 5] 79 | (- 5 4 3))) 80 | 81 | (export 82 | (define (swap-args proc) 83 | "Swap args of 2-argument procedure proc." 84 | (lambda (x y) [proc y x]))) 85 | 86 | (assert (equal [(swap-args 'cons) 1 2] 87 | (cons 2 1))) 88 | 89 | (export 90 | (define (memo-proc proc) 91 | "Memoize procedure proc of no arguments." 92 | (let ((run? ()) 93 | (result-values)) 94 | (lambda args 95 | (unless run? 96 | (setq result-values (multiple-value-list (apply proc args)) 97 | run? t) 98 | result-values) 99 | (values-list result-values))))) 100 | 101 | (export 102 | (define (disjoin* predicates) 103 | "Return a predicate equivalent to predicates joined together with or." 104 | (lambda (x) 105 | (let rec ((result nil) 106 | (predicates predicates)) 107 | (if (or result (null? predicates)) 108 | result 109 | (rec [(first predicates) x] 110 | (rest predicates))))))) 111 | (export 112 | (define (disjoin . predicates) 113 | "Return a predicate equivalent to predicates joined together with or." 114 | (disjoin* predicates))) 115 | 116 | (assert (equal (map (disjoin 'negative? 'even?) 117 | '(-1 -2 1 2)) 118 | '(t t nil t))) 119 | 120 | 121 | (export 122 | (define (conjoin* predicates) 123 | "Return a predicate equivalent to predicates joined together with and." 124 | (lambda (x) 125 | (let rec ((result t) 126 | (predicates predicates)) 127 | (if (or (not result) (null? predicates)) 128 | result 129 | (rec [(first predicates) x] 130 | (rest predicates))))))) 131 | (export 132 | (define (conjoin . predicates) 133 | "Return a predicate equivalent to predicates joined together with and." 134 | (conjoin* predicates))) 135 | 136 | (export 137 | (define (for-all* predicate lists) 138 | (apply #'every predicate lists))) 139 | (export 140 | (define (for-all predicate . lists) 141 | (for-all* predicate lists))) 142 | 143 | (export 144 | (define (there-exists* predicate lists) 145 | (apply #'some predicate lists))) 146 | (export 147 | (define (there-exists predicate . lists) 148 | (there-exists* predicate lists))) 149 | 150 | (assert (equal (map (conjoin 'negative? 'even?) 151 | '(-1 -2 1 2)) 152 | '(nil t nil nil))) 153 | 154 | (export 155 | (define (const v) 156 | "Return a procedure of 0+ args that always returns v" 157 | (lambda args 158 | (declare (ignore args)) 159 | v))) 160 | 161 | (assert (= [(const 3) 1 2 3] 3)) 162 | 163 | (uninstall-syntax!) 164 | -------------------------------------------------------------------------------- /src/promises.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:schemeish.backend) 2 | 3 | (install-syntax!) 4 | 5 | ;;; DELAY 6 | 7 | (defmacro delay (&body body) 8 | "Delays body." 9 | `(memo-proc (lambda () ,@body))) 10 | (export 'delay) 11 | (export 12 | (define (force promise) 13 | "Evaluates promise." 14 | [promise])) 15 | 16 | (uninstall-syntax!) 17 | -------------------------------------------------------------------------------- /src/queue.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:schemeish.backend) 2 | 3 | (install-syntax!) 4 | (export 5 | (define queue? (make-bundle-predicate :queue))) 6 | (export 7 | (define (make-queue (front-ptr ())) 8 | (define rear-ptr (last front-ptr)) 9 | (define (empty?) (null? front-ptr)) 10 | (define (front) 11 | (cond 12 | ((empty?) 13 | (error "Cannot get the front of an empty queue.")) 14 | (t (car front-ptr)))) 15 | (define (insert! item) 16 | (let ((new-pair (cons item '()))) 17 | (cond 18 | ((empty?) 19 | (setq front-ptr new-pair) 20 | (setq rear-ptr new-pair)) 21 | (t 22 | (set-cdr! rear-ptr new-pair) 23 | (setq rear-ptr new-pair))))) 24 | (define (delete!) 25 | (cond 26 | ((empty?) 27 | (error "Cannot delete from an empty queue.")) 28 | (t 29 | (setq front-ptr (cdr front-ptr))))) 30 | 31 | (bundle #'queue? 32 | empty? 33 | front 34 | insert! 35 | delete!))) 36 | 37 | (export 38 | (define (queue-empty? q) [[q :empty?]])) 39 | (export 40 | (define (queue-front q) [[q :front]])) 41 | (export 42 | (define (queue-insert! q item) 43 | [[q :insert!] item] 44 | q)) 45 | (export 46 | (define (queue-delete! q) 47 | [[q :delete!]] 48 | q)) 49 | 50 | (assert (queue? (make-queue))) 51 | (assert (queue-empty? (make-queue))) 52 | (let ((q (make-queue))) 53 | (assert (eq? q (queue-insert! q 1))) 54 | (assert (= 1 (queue-front q))) 55 | (queue-insert! q 2) 56 | (assert (= 1 (queue-front q))) 57 | (assert (eq? q (queue-delete! q))) 58 | (assert (= 2 (queue-front q))) 59 | (assert (queue-empty? (queue-delete! q))) 60 | 61 | (assert (null (ignore-errors (queue-front q)))) 62 | (assert (null (ignore-errors (queue-delete! q))))) 63 | 64 | (uninstall-syntax!) 65 | -------------------------------------------------------------------------------- /src/schemeish-package-definition.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:schemeish.backend) 2 | 3 | (install-syntax!) 4 | 5 | (define (define-schemeish-package) 6 | (define-package :schemeish.schemeish 7 | (nickname-package :schemeish :scm) 8 | (package-use-and-export-shadowing :cl :schemeish.internals :schemeish.backend))) 9 | 10 | (define (schemeish-package-file-contents) 11 | (package-file-contents (map #'find-package '(:schemeish.internals :schemeish.backend :schemeish.schemeish)))) 12 | 13 | (define (write-schemeish-package-file! (file-path "./src/package.lisp")) 14 | (with-open-file (stream file-path 15 | :direction :output 16 | :if-exists :supersede) 17 | (format stream "~A" (schemeish-package-file-contents)))) 18 | 19 | ;; (write-schemeish-package-file!) 20 | 21 | (uninstall-syntax!) 22 | -------------------------------------------------------------------------------- /src/set.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:schemeish.backend) 2 | 3 | (install-syntax!) 4 | 5 | ;;; Set! 6 | 7 | (defmacro set! (id expression) 8 | `(setq ,id ,expression)) 9 | (export 'set!) 10 | (export 11 | (define (set-car! pair value) (setf (car pair) value))) 12 | (export 13 | (define (set-cdr! pair value) (setf (cdr pair) value))) 14 | 15 | (uninstall-syntax!) 16 | -------------------------------------------------------------------------------- /src/sets.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:schemeish.backend) 2 | 3 | (install-syntax!) 4 | 5 | (export 6 | (define (set-member? set value) 7 | "True if value is a member of set." 8 | (member value set :test #'equal?))) 9 | (export 10 | (define (set-add set value) 11 | "Adds value to set." 12 | (if (set-member? set value) 13 | set 14 | (cons value set)))) 15 | (export 16 | (define (set-remove set value) 17 | "Removes value from set." 18 | (remove set value :test #'equal?))) 19 | (export 20 | (define (set-empty? set) 21 | "True if set is empty." 22 | (empty? set))) 23 | (export 24 | (define (set-count set) 25 | "Number of elements in set." 26 | (length set))) 27 | (export 28 | (define (set->stream set) 29 | "Returns the elements of set as a stream." 30 | (list->stream set))) 31 | (export 32 | (define (set-union . sets) 33 | "Returns the union of all sets." 34 | (foldl (lambda (set result) 35 | (union set result :test #'equal?)) 36 | () 37 | sets))) 38 | (export 39 | (define (set-intersect set . sets) 40 | "Return a set with all elements in set that are also in all sets." 41 | (foldl (lambda (set result) 42 | (intersection result set :test #'equal?)) 43 | set 44 | sets))) 45 | (export 46 | (define (set-subtract set . sets) 47 | "Return a set with all elements in set that are not in any of sets." 48 | (foldl (lambda (set result) 49 | (set-difference result set :test #'equal?)) 50 | set 51 | sets))) 52 | (export 53 | (define (subset? set1 set2) 54 | "True if set1 is a subset of set2" 55 | (set-empty? (set-subtract set1 set2)))) 56 | (export 57 | (define (set=? set1 set2) 58 | "True if set1 = set2" 59 | (and (subset? set1 set2) 60 | (subset? set2 set1)))) 61 | 62 | (uninstall-syntax!) 63 | -------------------------------------------------------------------------------- /src/splitf.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:schemeish.internals) 2 | 3 | (install-syntax!) 4 | 5 | (export 6 | (defun takef (list predicate) 7 | "Takes initial elements of list that satisfy pred." 8 | (labels ((rec (list result) 9 | (if (or (null list) (not [predicate (first list)])) 10 | (values (nreverse result) list) 11 | (rec 12 | (rest list) 13 | (cons (first list) result))))) 14 | (rec list ())))) 15 | 16 | (assert (equal (takef '(2 4 5 8) 'evenp) 17 | '(2 4))) 18 | (export 19 | (defun dropf (list predicate) 20 | "Drops initial elements of list that don't satisfy pred." 21 | (labels ((rec (list) 22 | (if (or (null list) (not [predicate (first list)])) 23 | list 24 | (rec (rest list))))) 25 | (rec list)))) 26 | 27 | (assert (equal (dropf '(2 4 5 8) 'evenp) 28 | '(5 8))) 29 | 30 | 31 | (export 32 | (defun splitf (list predicate) 33 | "Returns the (values (takef list predicate) (dropf list predicate))" 34 | (takef list predicate))) 35 | 36 | (uninstall-syntax!) 37 | -------------------------------------------------------------------------------- /src/stream-collect.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:schemeish.backend) 2 | 3 | (install-syntax!) 4 | 5 | (defmacro stream-collect (map-form bindings filter-form) 6 | "Given bindings ((b1 stream1) 7 | (b2 stream2) ...) 8 | Generates a stream all combinations of b1,b2..., 9 | Applies a filter to the generated stream using filter-form with b1,b2... bound. 10 | Applies a map to the filtered/generated stream using map-form with b1,b2... bound. 11 | Example: 12 | (define (prime-sum-pairs n) 13 | (stream-collect 14 | (list i j (+ i j)) 15 | ((i (stream-range 1 n)) 16 | (j (stream-range 1 (1- i)))) 17 | (prime? (+ i j)))) 18 | 19 | (prime-sum-pairs n) results in all of the (list i j (+ i j)) numbers i,j such that 0 < j < i <= n" 20 | (stream-collect-form map-form bindings filter-form)) 21 | (export 'stream-collect) 22 | 23 | (define (prime? num) 24 | (let ((root (floor (sqrt num)))) 25 | (not (find-if (lambda (div) (zerop (rem num div))) (range (1+ root) 2))))) 26 | 27 | (define (prime-sum-pairs n) 28 | (stream-collect 29 | (list i j (+ i j)) 30 | ((i (stream-range 1 n)) 31 | (j (stream-range 1 (1- i)))) 32 | (prime? (+ i j)))) 33 | 34 | (assert (equal (stream->list (prime-sum-pairs 6)) 35 | '((2 1 3) (3 2 5) (4 1 5) (4 3 7) (5 2 7) (6 1 7) (6 5 11)))) 36 | 37 | 38 | (uninstall-syntax!) 39 | -------------------------------------------------------------------------------- /src/streams.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:schemeish.backend) 2 | 3 | (install-syntax!) 4 | 5 | ;;; Streams 6 | 7 | (export 8 | (defvar *the-empty-stream* ())) 9 | (defmacro stream-cons (first rest) 10 | "Construct a stream from an element and a delayed stream." 11 | `(cons ,first (delay ,rest))) 12 | (export 'stream-cons) 13 | (export 14 | (define (stream-car stream) 15 | "First element of stream." 16 | (car stream))) 17 | (export 18 | (define (stream-cdr stream) 19 | "Forces the rest of the stream." 20 | (force (cdr stream)))) 21 | 22 | (export 23 | (define (stream-empty? stream) 24 | "T if the stream is *the-empty-stream*" 25 | (eq *the-empty-stream* stream))) 26 | 27 | (export 28 | (define (stream-for-each stream proc) 29 | "Applies proc to each element of stream, discarding results" 30 | (let rec ((stream stream)) 31 | (unless (stream-empty? stream) 32 | [proc (stream-car stream)] 33 | (rec (stream-cdr stream)))))) 34 | 35 | (export 36 | (define (stream-length stream) 37 | "The length of the stream." 38 | (let ((count 0)) 39 | (stream-for-each stream (lambda (x) (declare (ignore x)) (incf count))) 40 | count))) 41 | 42 | (export 43 | (define (stream->list stream) 44 | "A list of all of the elements in stream." 45 | (let ((xs ())) 46 | (stream-for-each stream (lambda (x) (push x xs))) 47 | (nreverse xs)))) 48 | 49 | (export 50 | (define (stream-first stream) 51 | "The first element of a stream." 52 | (stream-car stream))) 53 | (export 54 | (define (stream-rest stream) 55 | "Forces the rest of the stream." 56 | (stream-cdr stream))) 57 | 58 | (export 59 | (define (stream? datum) 60 | "True if datum is a stream-like object." 61 | (or (eq? datum *the-empty-stream*) 62 | (and (pair? datum) 63 | (procedure? (cdr datum)))))) 64 | 65 | (export 66 | (define (list->stream list) 67 | "Constructs a stream from a list of values." 68 | (if (empty? list) 69 | *the-empty-stream* 70 | (stream-cons (first list) (list->stream (rest list)))))) 71 | 72 | (export 73 | (define (stream . list) 74 | "Constructs a stream from a list of values." 75 | (list->stream list))) 76 | 77 | (defparameter *test-stream* (stream 1 2 3)) 78 | 79 | (assert (equal (stream->list *test-stream*) 80 | '(1 2 3))) 81 | 82 | (assert (equal (let* ((one 0) (two 1) (three 2) 83 | (stream (stream-cons (incf one) (stream-cons (incf two) (stream-cons (incf three) *the-empty-stream*))))) 84 | (stream->list stream) 85 | (stream->list stream)) 86 | '(1 2 3))) 87 | 88 | (export 89 | (define (stream-map proc stream) 90 | "A stream which has proc applied to each element." 91 | (if (stream-empty? stream) 92 | *the-empty-stream* 93 | (stream-cons [proc (stream-first stream)] (stream-map proc (stream-rest stream)))))) 94 | 95 | (assert (equal (stream->list (stream-map (lcurry '* 5) *test-stream*)) 96 | '(5 10 15))) 97 | 98 | (export 99 | (define (stream-fold proc init stream) 100 | "A stream which applies (proc accumulated-value element) to successive elements of stream." 101 | (cond 102 | ((stream-empty? stream) init) 103 | (t 104 | (let ((first (stream-first stream)) 105 | (rest (stream-rest stream))) 106 | (cond 107 | ((stream-empty? rest) [proc init first]) 108 | (t (stream-fold proc [proc init (stream-first stream)] rest)))))))) 109 | 110 | (assert (eq :init (stream-fold t :init *the-empty-stream*))) 111 | (assert (equal (stream-fold (swap-args 'cons) () *test-stream*) 112 | '(3 2 1))) 113 | 114 | (export 115 | (define (stream-filter predicate stream) 116 | "A stream with only the elements which satisfy predicate." 117 | (cond 118 | ((stream-empty? stream) stream) 119 | (t 120 | (let ((x (stream-first stream))) 121 | (if [predicate x] 122 | (stream-cons x (stream-filter predicate (stream-rest stream))) 123 | (stream-filter predicate (stream-rest stream)))))))) 124 | 125 | (assert (equal (stream->list (stream-filter 'odd? (stream 1 2 3))) 126 | '(1 3))) 127 | 128 | (export 129 | (define (stream-drop stream n) 130 | "A stream without the first n elements of stream." 131 | (let rec ((stream stream) 132 | (n n)) 133 | (if (or (stream-empty? stream) (<= n 0)) 134 | stream 135 | (rec (stream-rest stream) (1- n)))))) 136 | 137 | (assert (equal (stream->list (stream-drop (stream 1 2 3) 2)) 138 | '(3))) 139 | 140 | (export 141 | (define (stream-take stream n) 142 | "A stream with up to the first n elements of stream." 143 | (if (or (stream-empty? stream) (<= n 0)) 144 | *the-empty-stream* 145 | (stream-cons (stream-first stream) 146 | (stream-take (stream-rest stream) (1- n)))))) 147 | 148 | (assert (equal (stream->list (stream-take (stream 1 2 3) 2)) 149 | '(1 2))) 150 | 151 | (export 152 | (define (stream-ref stream i) 153 | "Returns the i-th element (0-based indexing) of stream." 154 | (stream-first (stream-drop stream i)))) 155 | 156 | (assert (= (stream-ref (stream 0 1 2 3) 1) 157 | 1)) 158 | 159 | (export 160 | (define (stream-append . streams) 161 | "A stream in which combines streams to follow one after the other." 162 | (cond 163 | ((null? streams) *the-empty-stream*) 164 | (t 165 | (let ((stream (first streams))) 166 | (cond 167 | ((stream-empty? stream) 168 | (apply 'stream-append (rest streams))) 169 | (t 170 | (stream-cons (stream-first stream) 171 | (apply 'stream-append 172 | (stream-rest stream) 173 | (rest streams)))))))))) 174 | 175 | (assert (equal 176 | (stream->list (stream-append (stream 1 2 3) (stream 4 5 6) (stream 7 8 9))) 177 | '(1 2 3 4 5 6 7 8 9))) 178 | 179 | (export 180 | (define (stream-flatten stream-of-streams) 181 | "A stream which combines a stream of streams into a single stream using stream-append." 182 | (stream-fold 'stream-append 183 | *the-empty-stream* 184 | stream-of-streams))) 185 | 186 | (assert (equal 187 | (stream->list (stream-flatten (stream (stream 1 2 3) 188 | (stream 4 5 6) 189 | (stream 7 8 9)))) 190 | '(1 2 3 4 5 6 7 8 9))) 191 | 192 | 193 | (export 194 | (define (stream-range start end) 195 | "A stream of integers from start up to (1- end)." 196 | (cond 197 | ((> start end) *the-empty-stream*) 198 | (t 199 | (stream-cons start 200 | (stream-range (1+ start) end)))))) 201 | 202 | (assert (equal (stream->list (stream-range 4 8)) 203 | '(4 5 6 7 8))) 204 | 205 | (export 206 | (define (stream-flatmap proc s) 207 | "Stream-flatten the result of mapping proc across stream s." 208 | (stream-flatten (stream-map proc s)))) 209 | 210 | (assert (equal (stream->list (stream-flatmap 211 | (lambda (i) 212 | (stream-map 213 | (lambda (j) (list i j)) 214 | (stream 4 5))) 215 | (stream 1 2))) 216 | '((1 4) (1 5) (2 4) (2 5)))) 217 | 218 | 219 | (export 220 | (define (stream-map-successive n f stream) 221 | "Apply f to successive groups of size n in stream." 222 | (let ((group (stream->list (stream-take stream n)))) 223 | (cond ((< (length group) n) 224 | *the-empty-stream*) 225 | (t (stream-cons (apply f group) 226 | (stream-map-successive n f (stream-rest stream)))))))) 227 | 228 | (assert (equal? (stream->list (stream-map-successive 3 'list (stream 1 2 3 4))) 229 | '((1 2 3) (2 3 4)))) 230 | 231 | 232 | (unexport 233 | (define (random-stream limit) 234 | "Return a stream of random numbers below limit. 235 | If limit is an integer, returns integers. 236 | If limit is a float returns floats. 237 | Does not affect the random-state." 238 | (define (%random-stream rs) 239 | (stream-cons (random limit rs) 240 | (%random-stream rs))) 241 | (%random-stream (make-random-state)))) 242 | 243 | ;; Random-stream does not affect the random-state 244 | (assert (equal (stream->list (stream-take (random-stream 1.0) 10)) 245 | (stream->list (stream-take (random-stream 1.0) 10)))) 246 | 247 | (assert (stream-empty? (stream-filter (lambda (x) (not (<= 0.0 x 1.0))) 248 | (stream-take (random-stream 1.0) 10)))) 249 | 250 | (uninstall-syntax!) 251 | -------------------------------------------------------------------------------- /src/strings.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:schemeish.backend) 2 | 3 | (install-syntax!) 4 | 5 | ;;; Strings 6 | 7 | (export 8 | (define (string-append . strings) 9 | (apply 'concatenate 'string strings))) 10 | 11 | (export 12 | (define (string-append* strings) 13 | "Applies string-append to strings." 14 | (apply #'string-append strings))) 15 | 16 | (export 17 | (define string? #'stringp)) 18 | 19 | (export 20 | (define (string-starts-with? string sub-string) 21 | (and (>= (length string) (length sub-string)) 22 | (string= (subseq string 0 (length sub-string)) 23 | sub-string)))) 24 | 25 | (export 26 | (define (chars-string char count) 27 | "Return a string with char repeated count times." 28 | (make-string count :initial-element char))) 29 | 30 | (export 31 | (define (join-strings strings separator) 32 | "Joins strings with the character separator in between each pair of strings." 33 | (string-append* (intersperse (chars-string separator 1) strings)))) 34 | 35 | (export 36 | (define (string-empty? string) 37 | "True if string is empty." 38 | (zero? (length string)))) 39 | 40 | (export 41 | (define (split-string-if string split-char?) 42 | "Return a list of strings that have been split whenever split-char? is true. 43 | Chars that satisfy split-char? will be removed, and empty strings will not be returned." 44 | (define (not-split-char? char) (not [split-char? char])) 45 | (define (first-char string) (aref string 0)) 46 | 47 | (define (split-string-iter string result) 48 | (cond 49 | ((string-empty? string) result) 50 | ([split-char? (first-char string)] 51 | ;; Remove initial split-char? 52 | (let ((start (position-if not-split-char? string))) 53 | (cond 54 | ((null? start) result) 55 | (t (split-string-iter (subseq string start) result))))) 56 | (t 57 | (let ((end (position-if split-char? string))) 58 | (cond 59 | ((null? end) (cons string result)) 60 | (t (split-string-iter (subseq string (1+ end)) (cons (subseq string 0 end) result)))))))) 61 | 62 | (nreverse (split-string-iter string ())))) 63 | 64 | (export 65 | (define (split-string string split-char) 66 | "Splits the string on each occurrence of split-char in string." 67 | (split-string-if string (lcurry #'char= split-char)))) 68 | 69 | (assert (equal? (split-string-if " the three wise men joined hands in holy matrimony. " (lcurry #'char= #\space)) 70 | '("the" "three" "wise" "men" "joined" "hands" "in" "holy" "matrimony."))) 71 | 72 | 73 | (export 74 | (define (string-for-each proc string) 75 | "Apply proc to each character in string." 76 | (define end (length string)) 77 | (define (iter index) 78 | (when (< index end) 79 | [proc (aref string index)] 80 | (iter (1+ index)))) 81 | (iter 0))) 82 | (export 83 | (define (string-map proc string) 84 | "Applies proc to each character in string, returning a new string 85 | of the results appended together. Proc is expected to return a character or string" 86 | (with-output-to-string (s) 87 | (string-for-each (lambda (char) 88 | (format s "~A" [proc char])) 89 | string)))) 90 | 91 | (export 92 | (define (string->list string) 93 | (coerce string 'list))) 94 | (export 95 | (define (list->string list) 96 | (coerce list 'string))) 97 | 98 | (uninstall-syntax!) 99 | -------------------------------------------------------------------------------- /src/struct.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:schemeish.struct) 2 | 3 | (install-syntax!) 4 | 5 | (defclass struct () () 6 | (:documentation "The base type for structures defined using DEFINE-STRUCT.")) 7 | (define (struct? datum) 8 | (typep datum 'struct)) 9 | (defgeneric struct-copy (struct) 10 | (:documentation "Returns a shallow copy of struct.")) 11 | (defmethod struct-copy (struct) 12 | (error "Struct ~S is not a known structure type." struct)) 13 | (defgeneric struct->list (transparent-struct) 14 | (:documentation "Returns a list of the form '(constructor-name field-values) for the transparent structure.")) 15 | (defmethod struct->list (struct) 16 | (error "Struct ~S is not a transparent structure." struct)) 17 | (defgeneric struct-accessors (transparent-struct) 18 | (:documentation "Returns a list of accessor symbols for the transparent structure.")) 19 | (defmethod struct-accessors (struct) 20 | (error "Struct ~S is not a transparent structure." struct)) 21 | 22 | (define (make-struct-info type-name super-type-name field-names) 23 | (alist :type-name type-name 24 | :super-type-name super-type-name 25 | :field-names field-names)) 26 | (define (struct-info-type-name si) (alist-ref si :type-name)) 27 | (define (struct-info-super-type-name si) (alist-ref si :super-type-name)) 28 | (define (struct-info-field-names si) (alist-ref si :field-names)) 29 | 30 | (defvar *struct-info-table* 31 | (make-hash-table :test #'eq) 32 | "Hash Table from structure type-name->struct-info") 33 | 34 | (define (get-struct-info type-name) 35 | (gethash type-name *struct-info-table* nil)) 36 | (define (set-struct-info! info) 37 | (let* ((type-name (struct-info-type-name info)) 38 | (existing-info (get-struct-info type-name))) 39 | (when (and existing-info 40 | (or (not (equal? (struct-info-super-type-name info) 41 | (struct-info-super-type-name existing-info))) 42 | (not (equal? (struct-info-field-names info) 43 | (struct-info-field-names existing-info))))) 44 | (warn "Modifying structure ~S. Any sub-classed structures need to be recompiled." type-name)) 45 | (setf (gethash type-name *struct-info-table*) info))) 46 | 47 | (define (struct-info-ancestor-fields info) 48 | "Returns an alist of ((ancestor . fields) ... (parent . fields) (me . fields)) From oldest generation to youngest." 49 | (let ((super-type-name (struct-info-super-type-name info))) 50 | (cond 51 | ((null? super-type-name) 52 | (list (cons (struct-info-type-name info) (struct-info-field-names info)))) 53 | (t 54 | (let ((super-struct-info (get-struct-info super-type-name))) 55 | (cond 56 | ((null? super-struct-info) 57 | (error "The super type ~S does not exist in the *struct-info-table*" super-type-name)) 58 | (t (append 59 | (struct-info-ancestor-fields super-struct-info) 60 | (list (cons (struct-info-type-name info) (struct-info-field-names info))))))))))) 61 | 62 | (define (struct-defclass-slot-name type-name field-name) 63 | (intern (string-append (symbol->string type-name) "-" (symbol->string field-name)))) 64 | 65 | (define (struct-defclass-slot-names type-name field-names) 66 | (map (lambda (field-name) (struct-defclass-slot-name type-name field-name)) 67 | field-names)) 68 | 69 | (assert (equal? (struct-defclass-slot-names 'point '(x y)) 70 | '(point-x point-y))) 71 | (define (ancestor-fields->field-names ancestor-fields) 72 | (append-map 'cdr ancestor-fields)) 73 | (define (ancestor-fields->slot-names ancestor-fields) 74 | (append* (alist-map ancestor-fields 75 | (lambda (type-name field-names) 76 | (struct-defclass-slot-names type-name field-names))))) 77 | 78 | (let ((*struct-info-table* (make-hash-table :test #'eq))) 79 | (set-struct-info! (make-struct-info 'grandpa () '(father))) 80 | (set-struct-info! (make-struct-info 'father 'grandpa '(son))) 81 | (set-struct-info! (make-struct-info 'son 'father '(grandpa))) 82 | 83 | (let ((ancestor-fields (struct-info-ancestor-fields (get-struct-info 'son)))) 84 | (assert (equal? (ancestor-fields->field-names ancestor-fields) 85 | '(father son grandpa))) 86 | (assert (equal? (ancestor-fields->slot-names ancestor-fields) 87 | '(grandpa-father father-son son-grandpa))))) 88 | 89 | 90 | (define (parse-struct-field-spec field-spec) 91 | (cond 92 | ((symbol? field-spec) (cons field-spec :immutable)) 93 | ((and (pair? field-spec) 94 | (symbol? (first field-spec))) 95 | (cond 96 | ((equal? (rest field-spec) '(:mutable)) 97 | (cons (first field-spec) :mutable)) 98 | (t (error "Unknown field-option(s): ~S" (rest field-spec))))) 99 | (t (error "bad thing to be a field-spec: ~S" field-spec)))) 100 | 101 | (assert (equal (parse-struct-field-spec 'field-name) 102 | '(FIELD-NAME . :IMMUTABLE))) 103 | (assert (equal (parse-struct-field-spec '(field-name :mutable)) 104 | '(FIELD-NAME . :MUTABLE))) 105 | 106 | (define (parse-struct-options struct-options) 107 | (cond 108 | ((empty? struct-options) ()) 109 | (t 110 | (let ((opt (first struct-options))) 111 | (cond 112 | ((or (eq? :opaque opt) 113 | (eq? :mutable opt)) 114 | (cons (cons opt ()) (parse-struct-options (rest struct-options)))) 115 | ((or (eq? :documentation opt) 116 | (eq? :super opt)) 117 | (cond 118 | ((or (null? (rest struct-options)) 119 | (keywordp (second struct-options))) 120 | (error "Expected form for struct-option ~S" opt)) 121 | (t 122 | (cons (cons opt (eval (second struct-options))) (parse-struct-options (cddr struct-options)))))) 123 | (t (error "Bad thing to be a struct-option ~S" opt))))))) 124 | 125 | 126 | (assert (equal? (parse-struct-options '(:opaque :mutable :super 'point :documentation "docs")) 127 | '((:OPAQUE) (:MUTABLE) (:SUPER . POINT) (:DOCUMENTATION . "docs")))) 128 | 129 | (define (struct-constructor-name type-name) 130 | (intern (string-append (symbol->string 'make-) (symbol->string type-name)))) 131 | 132 | (assert (eq? (struct-constructor-name 'point) 133 | 'make-point)) 134 | 135 | (define (struct-defclass-form type-name field-names super-type-name documentation) 136 | (let ((supers (cond ((null? super-type-name) '(struct)) 137 | (t `(,super-type-name))))) 138 | `(defclass ,type-name ,supers 139 | ,(struct-defclass-slot-names type-name field-names) 140 | ,@(when documentation `((:documentation ,documentation)))))) 141 | 142 | (assert (equal? (struct-defclass-form 'point '(x y) () ()) 143 | '(DEFCLASS POINT (struct) (point-x point-y)))) 144 | 145 | (assert (equal? (struct-defclass-form 'point3 '(z) 'point ()) 146 | '(DEFCLASS POINT3 (point) (point3-z)))) 147 | 148 | (define (struct-define-constructor-form type-name constructor-name field-names super-type-name) 149 | (let* ((ancestor-fields (struct-info-ancestor-fields (get-struct-info super-type-name))) 150 | (super-field-names (ancestor-fields->field-names ancestor-fields)) 151 | (super-slot-names (ancestor-fields->slot-names ancestor-fields))) 152 | `(define (,constructor-name ,@(append super-field-names field-names)) 153 | (let ((struct (make-instance ',type-name))) 154 | ,@(map (lambda (slot-name value-name) 155 | `(setf (slot-value struct ',slot-name) ,value-name)) 156 | super-slot-names 157 | super-field-names) 158 | ,@(map (lambda (slot-name value-name) 159 | `(setf (slot-value struct ',slot-name) ,value-name)) 160 | (struct-defclass-slot-names type-name field-names) 161 | field-names) 162 | struct)))) 163 | 164 | (assert (equal? (struct-define-constructor-form 'point 'make-point '(x y) '()) 165 | '(DEFINE (MAKE-POINT X Y) 166 | (LET ((STRUCT (MAKE-INSTANCE 'POINT))) 167 | (SETF (SLOT-VALUE STRUCT 'POINT-X) X) 168 | (SETF (SLOT-VALUE STRUCT 'POINT-Y) Y) 169 | STRUCT)))) 170 | 171 | (let ((*struct-info-table* (make-hash-table))) 172 | (set-struct-info! (make-struct-info 'point () '(x y))) 173 | 174 | (assert (equal? (struct-define-constructor-form 'point3 'make-point3 '(z) 'point) 175 | '(DEFINE (MAKE-POINT3 X Y Z) 176 | (LET ((STRUCT (MAKE-INSTANCE 'POINT3))) 177 | (SETF (SLOT-VALUE STRUCT 'POINT-X) X) 178 | (SETF (SLOT-VALUE STRUCT 'POINT-Y) Y) 179 | (SETF (SLOT-VALUE STRUCT 'POINT3-Z) Z) 180 | STRUCT))))) 181 | 182 | (define (struct-define-struct-copy-form type-name field-names super-type-name) 183 | (let* ((ancestor-fields (struct-info-ancestor-fields (get-struct-info super-type-name))) 184 | (super-slot-names (ancestor-fields->slot-names ancestor-fields))) 185 | `(defmethod struct-copy ((struct ,type-name)) 186 | (let ((copy (make-instance ',type-name))) 187 | ,@(map (lambda (slot-name) 188 | `(setf (slot-value copy ',slot-name) (slot-value struct ',slot-name))) 189 | super-slot-names) 190 | ,@(map (lambda (slot-name) 191 | `(setf (slot-value copy ',slot-name) (slot-value struct ',slot-name))) 192 | (struct-defclass-slot-names type-name field-names)) 193 | copy)))) 194 | 195 | (define (struct-define-struct->list-form type-name field-names super-type-name) 196 | (let* ((ancestor-fields (struct-info-ancestor-fields (get-struct-info super-type-name))) 197 | (super-slot-names (ancestor-fields->slot-names ancestor-fields))) 198 | `(defmethod struct->list ((struct ,type-name)) 199 | (list 200 | ',(struct-constructor-name type-name) 201 | ,@(map (lambda (slot-name) `(slot-value struct ',slot-name)) super-slot-names) 202 | ,@(map (lambda (slot-name) `(slot-value struct ',slot-name)) (struct-defclass-slot-names type-name field-names)))))) 203 | 204 | (define (struct-define-accessor-form type-name slot-name) 205 | `(define (,slot-name ,type-name) 206 | (slot-value ,type-name ',slot-name))) 207 | 208 | (assert (equal? (struct-define-accessor-form 'point 'point-x) 209 | '(DEFINE (POINT-X POINT) 210 | (SLOT-VALUE POINT 'POINT-X)))) 211 | 212 | (define (struct-define-struct-accessors-form type-name field-names super-type-name) 213 | (let* ((ancestor-fields (struct-info-ancestor-fields (get-struct-info super-type-name))) 214 | (super-slot-names (ancestor-fields->slot-names ancestor-fields))) 215 | `(defmethod struct-accessors ((struct ,type-name)) 216 | '(,@(append 217 | (map (lambda (slot-name) slot-name) super-slot-names) 218 | (map (lambda (slot-name) slot-name) (struct-defclass-slot-names type-name field-names))))))) 219 | 220 | (define (struct-define-field-setter-forms type-name field-name) 221 | (let ((setter-name (intern (string-append "SET-" (symbol->string type-name) "-" (symbol->string field-name) "!"))) 222 | (slot-name (struct-defclass-slot-name type-name field-name))) 223 | `(progn 224 | (define (,setter-name ,type-name value) 225 | (setf (slot-value ,type-name ',slot-name) value) 226 | value) 227 | (defsetf ,slot-name ,setter-name)))) 228 | 229 | (define (struct-define-equal?-form type-name field-names super-type-name) 230 | (let* ((ancestor-fields (struct-info-ancestor-fields (get-struct-info super-type-name))) 231 | (super-slot-names (ancestor-fields->slot-names ancestor-fields))) 232 | `(defmethod equal? ((object1 ,type-name) (object2 ,type-name)) 233 | (and 234 | ,@(append 235 | (map (lambda (slot-name) 236 | `(equal? (slot-value object1 ',slot-name) 237 | (slot-value object2 ',slot-name))) 238 | super-slot-names) 239 | (map (lambda (slot-name) 240 | `(equal? (slot-value object1 ',slot-name) 241 | (slot-value object2 ',slot-name))) 242 | (struct-defclass-slot-names type-name field-names))))))) 243 | 244 | (defparameter *self-evaluating-symbols* '(t nil)) 245 | (define (printable-field field) 246 | "Returns symbols as '(quote symbol), lists as '(list ...), 247 | dotted-lists as '(dotted-list ...) and conses as '(cons ...). 248 | For lists containing a cycle, just returns the list as is." 249 | (cond ((and (symbol? field) 250 | (not (keywordp field)) 251 | (not (member field *self-evaluating-symbols*))) 252 | `',field) 253 | ((pair? field) 254 | ;; Field is a list, list*, cons, or a cycle 255 | (let recurse ((xs field) 256 | (visited ()) 257 | (result ())) 258 | (cond 259 | ((empty? xs) 260 | ;; We are in a proper list 261 | `(list ,@(map #'printable-field field))) 262 | ((member xs visited) 263 | ;; We are in a cycle, just return the field 264 | field) 265 | ((pair? xs) 266 | ;; In the middle of the list, keep looking. 267 | (recurse (rest xs) (cons xs visited) (cons (first xs) result))) 268 | (t 269 | ;; xs is not empty or a list, we are in a dotted list or cons. 270 | (cond 271 | ;; Dotted-list 272 | ((pair? (rest field)) `(list* ,@(nreverse (map #'printable-field (cons xs result))))) 273 | (t `(cons ,(printable-field (car field)) ,(printable-field (cdr field))))))))) 274 | ;; Field is something else. Just print it. 275 | (t field))) 276 | 277 | (assert (equal? (printable-field :a) :a)) 278 | (assert (equal? (printable-field 'a) '(quote a))) 279 | (assert (equal? (printable-field 1) 1)) 280 | (assert (equal? (printable-field (list 1 2 3)) 281 | '(list 1 2 3))) 282 | (assert (equal? (printable-field (cons 1 (cons 2 3))) 283 | '(list* 1 2 3))) 284 | (assert (equal? (printable-field (cons 1 2)) 285 | '(cons 1 2))) 286 | (assert (equal? (printable-field (list (list 1) (list 2 (list 3)))) 287 | '(LIST (LIST 1) (LIST 2 (LIST 3))))) 288 | 289 | (define (print-transparent-struct struct stream) 290 | (let ((list (struct->list struct))) 291 | (print-object (cons (first list) (map #'printable-field (rest list))) 292 | stream))) 293 | 294 | (define (struct-define-print-object-form type-name) 295 | `(defmethod print-object ((struct ,type-name) stream) 296 | (print-transparent-struct struct stream))) 297 | 298 | (define (struct-define-type-predicate-form type-name predicate-name) 299 | `(define (,predicate-name datum) 300 | (typep datum ',type-name))) 301 | 302 | (assert (equal? (struct-define-type-predicate-form 'point 'point?) 303 | '(DEFINE (POINT? DATUM) 304 | (TYPEP DATUM 'POINT)))) 305 | 306 | (define (struct-form type-name field-specs struct-options) 307 | (let* ((parsed-field-specs (map 'parse-struct-field-spec field-specs)) 308 | (field-names (map 'car parsed-field-specs)) 309 | (slot-names (struct-defclass-slot-names type-name field-names)) 310 | (parsed-struct-options (parse-struct-options struct-options)) 311 | (super-type-name (alist-ref parsed-struct-options :super nil)) 312 | (constructor-name (struct-constructor-name type-name)) 313 | (predicate-name (intern (string-append (symbol->string type-name) "?")))) 314 | `(progn 315 | (set-struct-info! (make-struct-info ',type-name ',super-type-name ',field-names)) 316 | ,(struct-defclass-form type-name field-names super-type-name (alist-ref parsed-struct-options :documentation)) 317 | ,(struct-define-struct-copy-form type-name field-names super-type-name) 318 | ,@(cond ((not (alist-has-key? parsed-struct-options :opaque)) 319 | (list 320 | (struct-define-struct->list-form type-name field-names super-type-name) 321 | (struct-define-struct-accessors-form type-name field-names super-type-name) 322 | (struct-define-equal?-form type-name field-names super-type-name) 323 | (struct-define-print-object-form type-name))) 324 | (t ())) 325 | ,@(cond ((alist-has-key? parsed-struct-options :mutable) 326 | (map (lambda (field-name) 327 | (struct-define-field-setter-forms type-name field-name)) 328 | field-names)) 329 | (t 330 | (map (lambda (field-spec) 331 | (struct-define-field-setter-forms type-name (car field-spec))) 332 | (filter (lambda (field-spec) (eq? (cdr field-spec) :mutable)) 333 | parsed-field-specs)))) 334 | ,(struct-define-constructor-form type-name constructor-name 335 | field-names 336 | super-type-name) 337 | ,@(map (lambda (slot-name) (struct-define-accessor-form type-name slot-name)) 338 | slot-names) 339 | ,(struct-define-type-predicate-form type-name predicate-name) 340 | '(,type-name ,constructor-name ,predicate-name ,@slot-names)))) 341 | 342 | (struct-form 'point '(x y) '()) 343 | (struct-form 'point3 '(z) '(:super 'point)) 344 | (struct-form 'tpoint '(x y) '(:opaque)) 345 | (struct-form 'mpoint '(x y) '(:mutable)) 346 | (struct-form 'mypoint '(x (y :mutable)) '()) 347 | (struct-form 'mypoint '(x y) '(:documentation "docstring")) 348 | 349 | (uninstall-syntax!) 350 | -------------------------------------------------------------------------------- /src/symbols.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:schemeish.backend) 2 | 3 | (install-syntax!) 4 | 5 | ;;; SYMBOLS 6 | 7 | (export 8 | (define (make-keyword symbol) 9 | (intern (symbol-name symbol) :keyword))) 10 | (export 11 | (define symbol->string #'symbol-name)) 12 | (export 13 | (define symbol? #'symbolp)) 14 | 15 | (export 16 | (define (parameter? symbol (environment)) 17 | "Returns true if symbol is a parameter i.e. dynamically scoped." 18 | (eq? :special (trivial-cltl2:variable-information symbol environment)) 19 | 20 | #+slow-check-for-parameter 21 | (and (not (constantp symbol)) 22 | ;; If we have an error, its because the parameter has a type 23 | ;; associated with it. Therefore we know its a parameter. 24 | (eval `(not (ignore-errors 25 | (let (,symbol) 26 | (let ((f (lambda () ,symbol))) 27 | (let ((,symbol t)) 28 | (not (eq? [f] t))))))))))) 29 | 30 | 31 | (export 32 | (define (symbolicate . things) 33 | (intern (apply #'concatenate 'string (map #'string things))))) 34 | 35 | 36 | (uninstall-syntax!) 37 | -------------------------------------------------------------------------------- /src/syntax.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:schemeish.internals) 2 | 3 | (defun read-left-bracket (stream char) 4 | "Implements reader-macro for [. Transforms [forms...] => (funcall forms...)" 5 | (declare (ignore char)) 6 | (let ((form (read-delimited-list #\] stream t))) 7 | (if (null form) 8 | '() 9 | `(funcall ,@form)))) 10 | (defun read-right-bracket (stream char) 11 | "Implements reader-macro for ]. Throws an error if an ] is unmatched." 12 | (declare (ignore stream char)) 13 | (error "read: unmatched ]")) 14 | 15 | (defun read-commented-form (stream char n) 16 | "Implements reader-macro for #;FORM. Discards FORM." 17 | (declare (ignore char n)) 18 | (read stream nil (values) t) 19 | (values)) 20 | 21 | (export 22 | (defmacro install-syntax! () 23 | "Installs syntax in the current read table. 24 | [] See READ-LEFT-BRACKET 25 | #; See READ-COMMENTED-FORM 26 | #g See READ-GUARD-TAG 27 | #d See READ-DOCUMENTATION-TAG" 28 | `(for-macros 29 | (set-macro-character #\[ #'read-left-bracket) 30 | (set-macro-character #\] #'read-right-bracket) 31 | (set-dispatch-macro-character #\# #\; #'read-commented-form) 32 | (set-dispatch-macro-character #\# #\g #'read-guard-tag) 33 | (set-dispatch-macro-character #\# #\d #'read-documentation-tag)))) 34 | 35 | (export 36 | (defmacro uninstall-syntax! () 37 | "Uninstalls [], #;, #g, #d reader syntaxes if they were installed using INSTALL-SYNTAX!." 38 | `(for-macros 39 | (when (eq (get-macro-character #\[) #'read-left-bracket) 40 | (set-macro-character #\[ nil)) 41 | (when (eq (get-macro-character #\]) #'read-right-bracket) 42 | (set-macro-character #\] nil)) 43 | (when (eq (get-dispatch-macro-character #\# #\;) #'read-commented-form) 44 | (set-dispatch-macro-character #\# #\; nil)) 45 | (when (eq (get-dispatch-macro-character #\# #\g) #'read-guard-tag) 46 | (set-dispatch-macro-character #\# #\g nil)) 47 | (when (eq (get-dispatch-macro-character #\# #\d) #'read-documentation-tag) 48 | (set-dispatch-macro-character #\# #\D nil))))) 49 | -------------------------------------------------------------------------------- /src/trees.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:schemeish.backend) 2 | 3 | (install-syntax!) 4 | 5 | ;;; Tree 6 | 7 | (export 8 | (define (flatten tree) 9 | (cond 10 | ((null? tree) ()) 11 | ((pair? tree) (append (flatten (car tree)) (flatten (cdr tree)))) 12 | (t (list tree))))) 13 | 14 | (uninstall-syntax!) 15 | -------------------------------------------------------------------------------- /src/unique-symbol.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:schemeish.internals) 2 | 3 | (defvar *unique-symbol* #'gensym "Given a string create a unique symbol. Typically bound to gensym.") 4 | (export 5 | (defmacro with-readable-symbols (&body body) 6 | "Establishes a dynamic context around body where UNIQUE-SYMBOL will use INTERN instead of GENSYM." 7 | `(let ((*unique-symbol* (lambda (s) (intern (symbol-name (gensym s)))))) 8 | ,@body))) 9 | (export 10 | (defun unique-symbol (name-or-symbol) 11 | "Typically calls gensym on the string value of name-or-symbol. If in the dynamic context established by WITH-READABLE-SYMBOLS, 12 | will call intern on the string value of name-or-symbol." 13 | (funcall *unique-symbol* (if (symbolp name-or-symbol) 14 | (symbol-name name-or-symbol) 15 | name-or-symbol)))) -------------------------------------------------------------------------------- /src/vectors.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:schemeish.backend) 2 | 3 | (install-syntax!) 4 | 5 | ;;; Vectors 6 | 7 | (export 8 | (define (vector-ref vector index) 9 | (aref vector index))) 10 | (export 11 | (define (vector-set! vector index value) 12 | (setf (aref vector index) value))) 13 | 14 | (export 15 | (define (safe-vector-ref vector index out-of-bounds-result) 16 | "Returns the out-of-bounds-result if index is out of bounds." 17 | (if (>= index (length vector)) 18 | out-of-bounds-result 19 | (aref vector index)))) 20 | 21 | (export 22 | (define (vector->list vector) 23 | (coerce vector 'list))) 24 | (export 25 | (define (list->vector list) 26 | (coerce list 'vector))) 27 | 28 | (uninstall-syntax!) 29 | --------------------------------------------------------------------------------