├── .gitignore ├── LICENSE ├── README.md ├── base.rkt ├── base └── lang │ └── reader.rkt ├── force.rkt ├── info.rkt ├── lang └── reader.rkt ├── lazy-tool.rkt ├── lazy.rkt ├── lazy.scrbl ├── list.rkt ├── main.rkt └── tests ├── forcers.rkt ├── lang.rkt ├── main.rkt ├── promise.rkt └── space.rkt /.gitignore: -------------------------------------------------------------------------------- 1 | # Racket compiled files 2 | compiled/ 3 | 4 | # common backups, autosaves, lock files, OS meta-files 5 | *~ 6 | \#* 7 | .#* 8 | .DS_Store 9 | *.bak 10 | TAGS 11 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | This component of Racket is distributed under the under the Apache 2.0 2 | and MIT licenses. The user can choose the license under which they 3 | will be using the software. There may be other licenses within the 4 | distribution with which the user must also comply. 5 | 6 | See the files 7 | https://github.com/racket/racket/blob/master/racket/src/LICENSE-APACHE.txt 8 | and 9 | https://github.com/racket/racket/blob/master/racket/src/LICENSE-MIT.txt 10 | for the full text of the licenses. 11 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # lazy 2 | 3 | This the source for the Racket package: "lazy". 4 | 5 | ### Contributing 6 | 7 | Contribute to Racket by submitting a [pull request], reporting an 8 | [issue], joining the [development mailing list], or visiting the 9 | IRC or Slack channels. 10 | 11 | ### License 12 | 13 | Racket, including these packages, is free software, see [LICENSE] 14 | for more details. 15 | 16 | By making a contribution, you are agreeing that your contribution 17 | is licensed under the [Apache 2.0] license and the [MIT] license. 18 | 19 | [MIT]: https://github.com/racket/racket/blob/master/racket/src/LICENSE-MIT.txt 20 | [Apache 2.0]: https://www.apache.org/licenses/LICENSE-2.0.txt 21 | [pull request]: https://github.com/racket/lazy/pulls 22 | [issue]: https://github.com/racket/lazy/issues 23 | [development mailing list]: https://lists.racket-lang.org 24 | [LICENSE]: LICENSE 25 | -------------------------------------------------------------------------------- /base.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (for-syntax racket/base 4 | racket/syntax) 5 | (for-syntax stepper/private/syntax-property)) 6 | 7 | ;; ~ = lazy (or delayed) 8 | ;; ! = strict (or forced) 9 | ;; (See below for app-related names) 10 | 11 | ;; -------------------------------------------------------------------------- 12 | ;; Syntax utilities 13 | 14 | ;; taken & modified from swindle/misc.rkt 15 | (provide defsubst) ; useful utility 16 | (define-syntax (defsubst-process stx) 17 | (syntax-case stx () 18 | [(_ name (acc ...)) 19 | #'(define-syntax (name stx) 20 | (syntax-case stx () acc ...))] 21 | [(_ name (acc ...) id subst . more) (identifier? #'id) 22 | #'(defsubst-process 23 | name (acc ... 24 | (id (identifier? #'id) #'subst) 25 | ((id x (... ...)) #'(subst x (... ...)))) 26 | . more)] 27 | [(_ name (acc ...) n+a subst . more) 28 | #'(defsubst-process name (acc ... (n+a #'subst)) . more)])) 29 | (define-syntax defsubst 30 | (syntax-rules () 31 | [(_ (name . args) subst . more) 32 | (defsubst-process name () (name . args) subst . more)] 33 | [(_ name subst . more) 34 | (defsubst-process name () name subst . more)])) 35 | 36 | ;; utility for defining ~foo but make it look like # 37 | (define-syntax (define* stx) 38 | (syntax-case stx () 39 | [(_ ~name val) (identifier? #'~name) 40 | (let* ([~str (symbol->string (syntax-e #'~name))] 41 | [str (string->symbol (regexp-replace #rx"^[~*]" ~str ""))]) 42 | (with-syntax ([name (datum->syntax #'~name str #'~name)]) 43 | #'(define ~name (let ([name val]) (mark-lazy name)))))] 44 | [(_ (~name . xs) body ...) (identifier? #'~name) 45 | #'(define* ~name (lambda xs body ...))])) 46 | 47 | ;; -------------------------------------------------------------------------- 48 | ;; Delay/force etc 49 | 50 | (require "force.rkt") 51 | 52 | (provide ~) 53 | 54 | ;; the exposed `!' (and other similar !s) must be a special form in the lazy 55 | ;; language -- but this is achieved through the lazy #%app (~!%app below) 56 | ;; that treats it (and the others) specially: uses mzscheme's application 57 | (define-for-syntax strict-names 58 | (syntax->list #'(! !! !list !!list !values !!values))) 59 | 60 | ;; -------------------------------------------------------------------------- 61 | ;; Stepper utility fns 62 | 63 | (define-for-syntax (stepper-hide-operator stx) 64 | (stepper-syntax-property stx 'stepper-skipto (append skipto/cdr skipto/second))) 65 | (define-for-syntax (stepper-add-lazy-op-prop stx) 66 | (stepper-syntax-property stx 'lazy-op #t)) 67 | 68 | (define-syntax (hidden-car stx) 69 | (syntax-case stx () 70 | [(_ arg) (stepper-hide-operator (syntax/loc stx (car arg)))])) 71 | 72 | (define-syntax (hidden-cdr stx) 73 | (syntax-case stx () 74 | [(_ arg) (stepper-hide-operator (syntax/loc stx (cdr arg)))])) 75 | 76 | (define-syntax (hidden-! stx) 77 | (syntax-case stx () 78 | [(_ arg) (stepper-hide-operator (syntax/loc stx (! arg)))])) 79 | 80 | (define-syntax (mark-as-lazy-op stx) 81 | (syntax-case stx () 82 | [(_ arg) 83 | (identifier? #'arg) 84 | (stepper-add-lazy-op-prop (syntax/loc stx arg))] 85 | [(_ arg) #'arg])) 86 | 87 | (define-syntax (hidden-~ stx) 88 | (syntax-case stx () 89 | [(_ arg) (stepper-hide-operator (syntax/loc stx (~ arg)))])) 90 | 91 | ;; -------------------------------------------------------------------------- 92 | ;; Determine laziness 93 | 94 | (define-values (lazy-proc lazy-proc?) 95 | (let-values ([(type make pred ref set) 96 | (make-struct-type 97 | 'lazy-proc #f 1 0 #f null (current-inspector) 0)]) 98 | (values make pred))) 99 | (defsubst (lazy? x) (if (lazy-proc? x) #t (struct-constructor-procedure? x))) 100 | ;; a version that works on any value 101 | (defsubst (mark-lazy x) (if (procedure? x) (lazy-proc x) x)) 102 | 103 | ;; a few primitive constructors 104 | (define ~cons (lazy-proc cons)) 105 | (define ~list (lazy-proc list)) 106 | (define ~list* (lazy-proc list*)) 107 | (define ~vector (lazy-proc vector)) 108 | (define ~box (lazy-proc box)) 109 | ;; values is special, see below 110 | 111 | ;; -------------------------------------------------------------------------- 112 | ;; Implicit begin & multiple values 113 | 114 | ;; This is used for implicit body begins. It is slightly complex since it 115 | ;; should still be possible to use it for splicing up macro contents, so 116 | ;; definitions are used with a normal begin. The actual body turns into one 117 | ;; promise that, when forced, forces each of its expressions and returns the 118 | ;; last value. This effectively ties evaluation of all expressions in one 119 | ;; package, so (~begin foo bar) will always evaluate `foo' when the value of 120 | ;; `bar' is forced. 121 | (define-syntax ~begin 122 | (let ([ids (syntax->list 123 | #'(~define ~define-values define-syntax define-syntaxes 124 | define-struct struct require provide))]) 125 | (define (definition? stx) 126 | (and (identifier? stx) 127 | (ormap (lambda (id) (free-identifier=? id stx)) ids))) 128 | (lambda (stx) 129 | (syntax-case stx () 130 | ;; optimize simple cases 131 | [(_) #'(begin)] 132 | [(_ expr) #'expr] 133 | [(_ expr ...) 134 | (let loop ([exprs #'(expr ...)] [defs '()]) 135 | (syntax-case exprs () 136 | [((head . rest) expr ...) 137 | (definition? #'head) 138 | (loop #'(expr ...) (cons #'(head . rest) defs))] 139 | ;; only definitions 140 | [() #`(begin #,@(reverse defs))] 141 | ;; single expr 142 | [(expr) #`(begin #,@(reverse defs) expr)] 143 | [(expr ...) 144 | #`(begin #,@(reverse defs) (hidden-~ (begin (hidden-! expr) ...)))]))])))) 145 | 146 | ;; redefined to use lazy-proc and ~begin 147 | (define-syntax (~lambda stx) 148 | (syntax-case stx () 149 | [(_ args body0 body ...) 150 | (let ([n (syntax-local-name)]) 151 | (with-syntax ([lam (syntax-property 152 | (syntax/loc stx 153 | (lambda args (~begin body0 body ...))) 154 | 'inferred-name n)]) 155 | (syntax/loc stx (lazy-proc lam))))])) 156 | (provide (rename-out [~lambda λ])) 157 | 158 | ; (defsubst 159 | ; (~define (f . xs) body0 body ...) (define f (~lambda xs body0 body ...)) 160 | ; (~define v x) (define v x)) 161 | ;; STC: define ~define to add stepper-properties 162 | ;; had to duplicate some stuff from ~lambda 163 | (define-syntax (~define stx) 164 | (define (attach-inferred-name stx fn-name-stx) 165 | (syntax-property 166 | (stepper-syntax-property 167 | (stepper-syntax-property 168 | stx 169 | 'stepper-define-type 'shortened-proc-define) 170 | 'stepper-proc-define-name fn-name-stx) 171 | 'inferred-name fn-name-stx)) 172 | ; duplicated some stuff from ~lambda so I could add stepper-properties 173 | (syntax-case stx () 174 | [(_ (f . args) body0 body ...) 175 | (quasisyntax/loc stx 176 | (~define f 177 | (lazy-proc 178 | #,(attach-inferred-name 179 | #'(lambda args (~begin body0 body ...)) 180 | #'f) 181 | )))] 182 | [(_ name expr) #'(define name expr)])) 183 | 184 | (defsubst 185 | (~let [(x v) ...] body0 body ...) 186 | (let ([x v] ...) (~begin body0 body ...)) 187 | (~let name [(x v) ...] body0 body ...) 188 | (let name [(x v) ...] (~begin body0 body ...))) 189 | (defsubst (~let* [(x v) ...] body0 body ...) 190 | (let* ([x v] ...) (~begin body0 body ...))) 191 | (defsubst (~letrec [(x v) ...] body0 body ...) 192 | (letrec ([x v] ...) (~begin body0 body ...))) 193 | 194 | ;; parameterize should force its arguments 195 | (defsubst (~parameterize ([param val] ...) body ...) 196 | ;; like ~begin, delaying the whole thing is necessary to tie the evaluation 197 | ;; to whenever the value is actually forced 198 | (hidden-~ (parameterize ([param (hidden-! val)] ...) (~begin body ...)))) 199 | 200 | ;; Multiple values are problematic: Racket promises can use multiple 201 | ;; values, but to carry that out `call-with-values' should be used in all 202 | ;; places that deal with multiple values, which will make the whole thing 203 | ;; much slower (about twice in tight loops) -- but multiple values are rarely 204 | ;; used (spceifically, students never use them). So `values' is redefined to 205 | ;; produce a first-class tuple-holding struct, and `split-values' turns that 206 | ;; into multiple values. 207 | ;; STC: add inspector for lazy stepper 208 | (struct multiple-values (values) #:inspector (make-inspector)) 209 | (define (split-values x) 210 | (let ([x (! x)]) 211 | (if (multiple-values? x) (apply values (multiple-values-values x)) x))) 212 | (define-syntax (hidden-split-values stx) 213 | (syntax-case stx () 214 | [(_ arg) (stepper-hide-operator (syntax/loc stx (split-values arg)))])) 215 | ;; Force and split resulting values. 216 | (define (!values x) 217 | (split-values (! x))) 218 | ;; Similar, but forces the actual values too. 219 | (define (!!values x) 220 | (let ([x (! x)]) 221 | (if (multiple-values? x) 222 | (apply values (map ! (multiple-values-values x))) 223 | x))) 224 | 225 | (define* ~values 226 | (lambda xs (multiple-values xs))) 227 | 228 | ;; Redefine multiple-value constructs so they split the results 229 | (defsubst (~define-values (v ...) body) 230 | (define-values (v ...) (hidden-split-values body))) 231 | (defsubst (~let-values ([(x ...) v] ...) body ...) 232 | (let-values ([(x ...) (split-values v)] ...) (~begin body ...))) 233 | (defsubst (~let*-values ([(x ...) v] ...) body ...) 234 | (let*-values ([(x ...) (split-values v)] ...) (~begin body ...))) 235 | (defsubst (~letrec-values ([(x ...) v] ...) body ...) 236 | (letrec-values ([(x ...) (split-values v)] ...) (~begin body ...))) 237 | 238 | ;; Redefine things that return multiple values. 239 | ;; (todo: only stuff necessary for the datatypes are done, more needed) 240 | (define* (~make-struct-type . args) 241 | (let ([args (!!list args)]) 242 | (call-with-values (lambda () (apply make-struct-type args)) ~values))) 243 | 244 | ;; -------------------------------------------------------------------------- 245 | ;; Applications 246 | 247 | ;; Basic names: 248 | ;; `app': syntax, calls a function over given arguments 249 | ;; `apply': function, last argument is a list of arguments to the function 250 | ;; Conventions: 251 | ;; `!*---': forces args when needed (depending on the function) 252 | ;; doesn't force the function (internal use only) 253 | ;; `!---': forces function, and forces args when needed 254 | ;; `~!---': adds a delay wrapper to the application (uses the above) 255 | ;; (this is a macro in the `apply' case too) 256 | ;; `~!*---': like the previous, but does not force the function (internal) 257 | ;; Provided stuff: 258 | ;; `~!%app': provided as `#%app' -- similar to `~!app' but treats a few 259 | ;; application kinds as special (mostly all kinds of forces) 260 | ;; `!apply': provided as `apply' (no need to provide `~!apply', since all 261 | ;; function calls are delayed by `#%app') 262 | 263 | (define (extract-if-lazy-proc f) 264 | (or (procedure-extract-target f) f)) 265 | (define-syntax (!*app stx) 266 | (syntax-case stx () 267 | [(_ f x ...) 268 | (let ([$$ (lambda (stx) 269 | (stepper-syntax-property 270 | stx 271 | 'stepper-skipto 272 | (append skipto/cddr 273 | `(both-l () (car)))))] 274 | [$ (lambda (stx) 275 | (stepper-syntax-property 276 | stx 277 | 'stepper-skipto 278 | (append skipto/cdr 279 | skipto/first)))]) 280 | (with-syntax* ([(y ...) (for/list ([decl (in-list (syntax->list #'(x ...)))]) 281 | (if (keyword? (syntax->datum decl)) 282 | decl 283 | (generate-temporary decl)))] 284 | [(y-ids ...) (filter (λ (decl) (not (keyword? (syntax->datum decl)))) 285 | (syntax->list #'(y ...)))]) 286 | ;; use syntax/loc for better errors etc 287 | (with-syntax ([lazy (syntax/loc stx ((extract-if-lazy-proc p) y ...))] 288 | [strict (syntax/loc stx (p (hidden-! y-ids) ...))]) 289 | (quasisyntax/loc stx 290 | ((lambda (p y ...) 291 | #,($$ #'(if (lazy? p) lazy strict))) 292 | f x ...) 293 | #;(let ([p f] [y x] ...) 294 | ;; #,($$ #`(if (lazy? p) lazy strict)) 295 | (if (lazy? p) lazy strict))))))])) 296 | 297 | (defsubst (!app f x ...) (!*app (hidden-! (mark-as-lazy-op f)) x ...)) 298 | (defsubst (~!*app f x ...) (hidden-~ (!*app f x ...))) 299 | (defsubst (~!app f x ...) (hidden-~ (!app f x ...))) 300 | 301 | (define-for-syntax (toplevel?) 302 | (memq (syntax-local-context) 303 | '(top-level module module-begin))) ; not sure about module-begin 304 | 305 | ;; What happens when encoutering a toplevel non-definition expression? 306 | (provide toplevel-forcer) 307 | (define toplevel-forcer (make-parameter !)) 308 | 309 | (provide (rename-out [~!%app #%app])) ; all applications are delayed 310 | (define-syntax (~!%app stx) ; provided as #%app 311 | #;(define (unwinder stx rec) 312 | (syntax-case stx (!) 313 | [(let-values ([(_p) (_app ! f)] [(_y) x] ...) _body) 314 | (with-syntax ([(f x ...) (rec #'(f x ...))]) 315 | #'(f x ...))])) 316 | #;(define (stepper-annotate stx) 317 | (let* ([stx (stepper-syntax-property stx 'stepper-hint unwinder)] 318 | [stx (stepper-syntax-property stx 'stepper-skip-double-break #t)]) 319 | stx)) 320 | (syntax-case stx (~) 321 | [(_ ~ x) (syntax/loc stx (~ x))] ; not really needed 322 | [(_ f x ...) 323 | (cond [(let ([f #'f]) 324 | (and (identifier? f) 325 | (ormap (lambda (s) (free-identifier=? f s)) 326 | strict-names))) 327 | ;; strict function => special forms => use plain application 328 | (syntax/loc stx (f x ...))] 329 | [(toplevel?) 330 | ;; toplevel expressions are always forced 331 | (syntax/loc stx ((toplevel-forcer) (!app f x ...)))] 332 | [else (syntax/loc stx (~!app f x ...))])])) 333 | 334 | (define (!*apply f . xs) 335 | (let ([xs (!list (apply list* xs))]) 336 | (apply f (if (lazy? f) xs (map ! xs))))) 337 | (define* (!apply f . xs) 338 | (let ([f (! f)] [xs (!list (apply list* xs))]) 339 | (apply f (if (lazy? f) xs (map ! xs))))) 340 | (defsubst (~!*apply f . xs) (hidden-~ (!*apply f . xs))) 341 | (defsubst (~!apply f . xs) (hidden-~ (!apply f . xs))) 342 | 343 | (provide (rename-out [!apply apply])) ; can only be used through #%app => delayed 344 | 345 | ;; do the same special treatment for toplevel variable expressions 346 | (provide (rename-out [!top #%top])) 347 | (define-syntax (!top stx) 348 | (syntax-case stx () 349 | [(_ . id) (if (toplevel?) #'(! (#%top . id)) #'(#%top . id))])) 350 | 351 | ;; used for explicitly strict/lazy calls 352 | (defsubst (strict-call f x ...) (hidden-~ (f (! x) ...))) 353 | (defsubst (lazy-call f x ...) (hidden-~ (f x ...))) 354 | 355 | ;; -------------------------------------------------------------------------- 356 | ;; Special forms that are now functions 357 | 358 | ;; Since these things are rarely used as functions, they are defined as 359 | ;; macros that expand to the function form when used as an expression. 360 | 361 | (define* *if 362 | (case-lambda [(e1 e2 e3) (if (! e1) e2 e3)] 363 | [(e1 e2 ) (when (! e1) e2 )])) 364 | (defsubst (~if e1 e2 e3) (hidden-~ (if (hidden-! e1) e2 e3)) 365 | (~if e1 e2 ) (hidden-~ (if (hidden-! e1) e2 )) 366 | ~if *if) 367 | 368 | (define* (*and . xs) 369 | (let ([xs (!list xs)]) 370 | (or (null? xs) 371 | (let loop ([x (car xs)] [xs (cdr xs)]) 372 | (if (null? xs) x (and (! x) (loop (car xs) (cdr xs)))))))) 373 | (define-syntax !and 374 | (syntax-rules () 375 | [(_) (and)] 376 | [(_ x ... y) (and (hidden-! x) ... y)])) 377 | (defsubst (~and x ...) (hidden-~ (!and x ...)) ~and *and) 378 | 379 | (define* (*or . xs) 380 | (let ([xs (!list xs)]) 381 | (and (pair? xs) 382 | (let loop ([x (car xs)] [xs (cdr xs)]) 383 | (if (null? xs) x (or (! x) (loop (car xs) (cdr xs)))))))) 384 | (define-syntax !or 385 | (syntax-rules () 386 | [(_) (or)] 387 | [(_ x ... y) (or (hidden-! x) ... y)])) 388 | (defsubst (~or x ...) (hidden-~ (!or x ...)) ~or *or) 389 | 390 | ;; -------------------------------------------------------------------------- 391 | ;; Special forms that are still special forms since they use ~begin 392 | 393 | (defsubst (~begin0 x y ...) ; not using ~begin, but equivalent 394 | (hidden-~ (let ([val (hidden-! x)]) (hidden-! y) ... val))) 395 | 396 | (defsubst (~when e x ...) (hidden-~ (when (hidden-! e) (~begin x ...)))) 397 | (defsubst (~unless e x ...) (hidden-~ (unless (hidden-! e) (~begin x ...)))) 398 | 399 | ;; -------------------------------------------------------------------------- 400 | ;; Misc stuff 401 | 402 | ;; Just for fun... 403 | (defsubst (~set! id expr) (hidden-~ (set! id (hidden-! expr)))) 404 | ;; The last ! above is needed -- without it: 405 | ;; (let ([a 1] [b 2]) (set! a (add1 b)) (set! b (add1 a)) a) 406 | ;; goes into an infinite loop. (Thanks to Jos Koot) 407 | 408 | (define* (~set-mcar! mpair val) (~ (set-mcar! (! mpair) val))) 409 | (define* (~set-mcdr! mpair val) (~ (set-mcdr! (! mpair) val))) 410 | (define* (~vector-set! vec i val) (~ (vector-set! (! vec) (! i) val))) 411 | (define* (~set-box! box val) (~ (set-box! (! box) val))) 412 | 413 | ;; not much to do with these besides inserting strictness points and ~begin 414 | ; for stepper: change else to #t test, add new error else branch 415 | (define-syntax (~cond stx) 416 | (syntax-case stx () 417 | [(_ clause ...) ; stepper needs the loc of the full clause 418 | (with-syntax 419 | ([(new-clause ...) 420 | (map 421 | (λ (c) 422 | (with-syntax ([(test body ...) c]) 423 | (with-syntax 424 | ([new-test 425 | (syntax-case #'test (else) 426 | [else ; for stepper 427 | (stepper-syntax-property #'#t 'stepper-else #t)] 428 | [x (syntax/loc #'x (hidden-! x))])]) 429 | (syntax/loc c (new-test (~begin body ...)))))) 430 | (syntax->list #'(clause ...)))] 431 | [new-else-body (syntax/loc stx (error 'cond "should not get here"))]) 432 | (quasisyntax/loc stx 433 | (hidden-~ 434 | #,(syntax/loc stx 435 | (cond 436 | new-clause ... 437 | [else new-else-body])))))])) 438 | (defsubst (~case v [keys body ...] ...) 439 | (hidden-~ (case (hidden-! v) [keys (~begin body ...)] ...))) 440 | 441 | ;; Doing this will print the whole thing, but problems with infinite things 442 | (define* (~error . args) (apply error (!! args))) 443 | 444 | ;; I/O shows the whole thing 445 | (define* (~printf fmt . args) (apply printf (! fmt) (!! args))) 446 | (define* (~fprintf p fmt . args) (apply fprintf (! p) (! fmt) (!! args))) 447 | (define* (~display x . port) (apply display (!! x) (!!list port))) 448 | (define* (~write x . port) (apply write (!! x) (!!list port))) 449 | (define* (~print x . port) (apply print (!! x) (!!list port))) 450 | 451 | ;; -------------------------------------------------------------------------- 452 | ;; Equality functions 453 | 454 | ;; All of these try to stop if the promises are the same. 455 | 456 | (define* (~eq? . args) 457 | (or (apply eq? (!list args)) (apply eq? (!!list args)))) 458 | 459 | (define* (~eqv? . args) 460 | (or (apply eqv? (!list args)) (apply eqv? (!!list args)))) 461 | 462 | ;; for `equal?' we must do a recursive scan 463 | (define (equal2? x y) 464 | (cond [(pair? x) (and (pair? y) 465 | (~equal? (car x) (car y)) 466 | (~equal? (cdr x) (cdr y)))] 467 | [(vector? x) 468 | (let ([k (vector-length x)]) 469 | (and (vector? y) 470 | (= k (vector-length y)) 471 | (let loop ([i 0]) 472 | (or (= i k) 473 | (and (~equal? (vector-ref x i) (vector-ref y i)) 474 | (loop (add1 i)))))))] 475 | [(struct? x) 476 | (and (struct? y) 477 | (let-values ([(xtype xskipped?) (struct-info x)] 478 | [(ytype yskipped?) (struct-info y)]) 479 | (and xtype ytype (not xskipped?) (not yskipped?) 480 | (eq? xtype ytype) 481 | (let*-values ([(name initk autok ref set imms spr skp?) 482 | (struct-type-info xtype)] 483 | [(k) (+ initk autok)]) 484 | (let loop ([i 0]) 485 | (or (= i k) (and (~equal? (ref x i) (ref y i)) 486 | (loop (add1 i)))))))))] 487 | [(box? x) (and (box? y) (~equal? (unbox x) (unbox y)))] 488 | [else #f])) 489 | (define* (~equal? x y . args) 490 | (let ([args (!list args)]) 491 | (if (pair? args) 492 | (and (~equal? x y) (apply ~equal? x (cdr args))) 493 | (or (equal? x y) 494 | (let ([x (! x)] [y (! y)]) 495 | (or (equal? x y) (equal2? x y))))))) 496 | 497 | ;; -------------------------------------------------------------------------- 498 | ;; List functions 499 | 500 | (define* (~list? x) (list? (!list x))) ; must force the whole list 501 | (define* (~length l) (length (!list l))) ; for these 502 | 503 | (define* (~car x) (car (! x))) ; these are for internal use: ~!app will do 504 | (define* (~cdr x) (cdr (! x))) ; this job when using this language 505 | (define* (~caar x) (car (! (car (! x))))) 506 | (define* (~cadr x) (car (! (cdr (! x))))) 507 | (define* (~cdar x) (cdr (! (car (! x))))) 508 | (define* (~cddr x) (cdr (! (cdr (! x))))) 509 | (define* (~caaar x) (car (! (~caar x)))) 510 | (define* (~caadr x) (car (! (~cadr x)))) 511 | (define* (~cadar x) (car (! (~cdar x)))) 512 | (define* (~caddr x) (car (! (~cddr x)))) 513 | (define* (~cdaar x) (cdr (! (~caar x)))) 514 | (define* (~cdadr x) (cdr (! (~cadr x)))) 515 | (define* (~cddar x) (cdr (! (~cdar x)))) 516 | (define* (~cdddr x) (cdr (! (~cddr x)))) 517 | (define* (~caaaar x) (car (! (~caaar x)))) 518 | (define* (~caaadr x) (car (! (~caadr x)))) 519 | (define* (~caadar x) (car (! (~cadar x)))) 520 | (define* (~caaddr x) (car (! (~caddr x)))) 521 | (define* (~cadaar x) (car (! (~cdaar x)))) 522 | (define* (~cadadr x) (car (! (~cdadr x)))) 523 | (define* (~caddar x) (car (! (~cddar x)))) 524 | (define* (~cadddr x) (car (! (~cdddr x)))) 525 | (define* (~cdaaar x) (cdr (! (~caaar x)))) 526 | (define* (~cdaadr x) (cdr (! (~caadr x)))) 527 | (define* (~cdadar x) (cdr (! (~cadar x)))) 528 | (define* (~cdaddr x) (cdr (! (~caddr x)))) 529 | (define* (~cddaar x) (cdr (! (~cdaar x)))) 530 | (define* (~cddadr x) (cdr (! (~cdadr x)))) 531 | (define* (~cdddar x) (cdr (! (~cddar x)))) 532 | (define* (~cddddr x) (cdr (! (~cdddr x)))) 533 | 534 | (define* (~list-ref l k) 535 | (let ([k (! k)]) 536 | (unless (exact-nonnegative-integer? k) 537 | (raise-type-error 'list-ref "non-negative exact integer" 1 l k)) 538 | (let loop ([k k] [l (! l)]) 539 | (cond [(not (pair? l)) 540 | (raise-type-error 'list-ref "proper list" l)] 541 | [(zero? k) (car l)] 542 | [else (loop (sub1 k) (! (cdr l)))])))) 543 | (define* (~list-tail l k) 544 | (let ([k (! k)]) 545 | (unless (exact-nonnegative-integer? k) 546 | (raise-type-error 'list-tail "non-negative exact integer" 1 l k)) 547 | (let loop ([k k] [l l]) ; don't force here -- unlike list-ref 548 | (cond [(zero? k) l] 549 | [else (let ([l (! l)]) 550 | (unless (pair? l) 551 | (raise-type-error 'list-tail "list" l)) 552 | (loop (sub1 k) (cdr l)))])))) 553 | 554 | (define* (~append . xs) 555 | (let ([xs (!list xs)]) 556 | (cond [(null? xs) '()] 557 | [(null? (cdr xs)) (car xs)] 558 | [else (let ([ls (~ (apply ~append (cdr xs)))]) 559 | (let loop ([l (! (car xs))]) 560 | (if (null? l) 561 | ls 562 | (cons (car l) (~ (loop (! (cdr l))))))))]))) 563 | 564 | ;; useful utility for many list functions below 565 | (define (!cdr l) (! (cdr l))) 566 | 567 | (define-syntax (deflistiter stx) 568 | (syntax-case stx (extra: null ->) 569 | [(deflistiter (?~name ?proc ?args ... ?l . ?ls) 570 | null -> ?base 571 | ?loop -> ?step-single ?step-multiple) 572 | #'(deflistiter (?~name ?proc ?args ... ?l . ?ls) 573 | extra: 574 | null -> ?base 575 | ?loop -> ?step-single ?step-multiple)] 576 | [(deflistiter (?~name ?proc ?args ... ?l . ?ls) 577 | extra: [?var ?init] ... 578 | null -> ?base 579 | ?loop -> ?step-single ?step-multiple) 580 | (with-syntax ([?name (let* ([x (symbol->string (syntax-e #'?~name))] 581 | [x (regexp-replace #rx"^~" x "")] 582 | [x (string->symbol x)]) 583 | (datum->syntax #'?~name x #'?~name))]) 584 | #'(define* ?~name 585 | (case-lambda 586 | [(?proc ?args ... ?l) 587 | (let ([?proc (hidden-! ?proc)]) 588 | (let ?loop ([?l (hidden-! ?l)] [?var ?init] ...) 589 | (if (null? ?l) 590 | ?base 591 | ?step-single)))] 592 | [(?proc ?args ... ?l . ?ls) 593 | (let ([?proc (hidden-! ?proc)]) 594 | (let ?loop ([?ls (cons (hidden-! ?l) (!!list ?ls))] [?var ?init] ...) 595 | (if (ormap null? ?ls) 596 | (if (andmap null? ?ls) 597 | ?base 598 | (error '?name "all lists must have same size")) 599 | ?step-multiple)))])))])) 600 | 601 | ;; These use the `*' version of app/ly, to avoid forcing the function over 602 | ;; and over -- `deflistiter' forces it on entry 603 | (deflistiter (~map proc l . ls) 604 | null -> '() 605 | loop -> (cons (~!*app proc (car l)) (~ (loop (! (cdr l))))) 606 | (cons (~!*apply proc (map car ls)) (~ (loop (map !cdr ls))))) 607 | (deflistiter (~for-each proc l . ls) 608 | null -> (void) 609 | loop -> (begin (! (!*app proc (car l))) (loop (! (cdr l)))) 610 | (begin (! (!*apply proc (map car ls))) (loop (map !cdr ls)))) 611 | (deflistiter (~andmap proc l . ls) 612 | null -> #t 613 | loop -> (and (! (!*app proc (car l))) (loop (! (cdr l)))) 614 | (and (! (!*apply proc (map car ls))) (loop (map !cdr ls)))) 615 | (deflistiter (~ormap proc l . ls) 616 | null -> #f 617 | loop -> (or (! (!*app proc (car l))) (loop (! (cdr l)))) 618 | (or (! (!*apply proc (map car ls))) (loop (map !cdr ls)))) 619 | (deflistiter (foldl proc init l . ls) 620 | extra: [acc init] 621 | null -> acc 622 | loop -> 623 | (~ (loop (! (cdr l)) (~!*app proc (car l) acc))) 624 | (~ (loop (map !cdr ls) 625 | (~!*apply proc (append (map car ls) (list acc)))))) 626 | (deflistiter (foldr proc init l . ls) 627 | null -> init 628 | loop -> 629 | (~!*app proc (car l) (~ (loop (! (cdr l))))) 630 | (~!*apply proc (append (map car ls) (list (~ (loop (map !cdr ls))))))) 631 | 632 | (define (do-member name = elt list) ; no currying for procedure names 633 | ;; `elt', `=', and `name' are always forced values 634 | (let loop ([list (! list)]) 635 | (cond [(null? list) #f] 636 | [(not (pair? list)) (error name "not a proper list: ~e" list)] 637 | [(= elt (! (car list))) list] 638 | [else (loop (! (cdr list)))]))) 639 | (define* (~member elt list) (do-member 'member ~equal? (! elt) list)) 640 | (define* (~memq elt list) (do-member 'memq ~eq? (! elt) list)) 641 | (define* (~memv elt list) (do-member 'memv ~eqv? (! elt) list)) 642 | 643 | (define (do-assoc name = key alist) ; no currying for procedure names 644 | ;; `key', `=', and `name' are always forced values 645 | (let loop ([alist (! alist)]) 646 | (cond [(null? alist) #f] 647 | [(not (pair? alist)) (error name "not a proper list: ~e" alist)] 648 | [else (let ([cell (! (car alist))]) 649 | (cond [(not (pair? cell)) 650 | (error name "non-pair found in list: ~e" cell)] 651 | [(= (! (car cell)) key) cell] 652 | [else (loop (! (cdr alist)))]))]))) 653 | (define* (~assoc key alist) (do-assoc 'assoc ~equal? (! key) alist)) 654 | (define* (~assq key alist) (do-assoc 'assq ~eq? (! key) alist)) 655 | (define* (~assv key alist) (do-assoc 'assv ~eqv? (! key) alist)) 656 | 657 | (define* (~reverse list) 658 | (let ([list (!list list)]) 659 | (reverse list))) 660 | 661 | ;; -------------------------------------------------------------------------- 662 | ;; Extra functionality that is useful for lazy list stuff 663 | 664 | (define* (take n l) 665 | (let ([n0 (! n)]) 666 | (unless (exact-nonnegative-integer? n0) 667 | (raise-type-error 'take "non-negative exact integer" 0 n0 l)) 668 | (let loop ([n n0] [l l]) 669 | (if (zero? n) 670 | '() 671 | (let ([l (! l)]) 672 | (cond [(null? l) 673 | ;; it would be fine to force the whole list (since we now 674 | ;; know it's finite), but doing so means keeping a reference 675 | ;; to its head, which can lead to memory leaks. 676 | (error 'take "index ~e too large for input list" n0)] 677 | [(pair? l) (cons (car l) (~ (loop (sub1 n) (cdr l))))] 678 | [else (error 'take "not a proper list: ~e" l)])))))) 679 | 680 | ;; not like Haskell's `cycle' that consumes a list 681 | (define* (cycle . l) 682 | (letrec ([r (~ (~append (! l) r))]) 683 | r)) 684 | 685 | ;; -------------------------------------------------------------------------- 686 | ;; mzlib/list functionality 687 | 688 | ;; These are a hack, they're not the same due to different error 689 | ;; messages (and they work with improper lists too). 690 | (define* (rest x) (~cdr x)) 691 | (define* (first x) (~car x)) 692 | (define* (second x) (~cadr x)) 693 | (define* (third x) (~caddr x)) 694 | (define* (fourth x) (~cadddr x)) 695 | (define* (fifth x) (~car (~cddddr x))) 696 | (define* (sixth x) (~cadr (~cddddr x))) 697 | (define* (seventh x) (~caddr (~cddddr x))) 698 | (define* (eighth x) (~cadddr (~cddddr x))) 699 | (define* (cons? x) (pair? (! x))) 700 | (define* empty null) 701 | (define* (empty? x) (null? (! x))) 702 | 703 | (define (do-remove name item list =) 704 | (let ([= (! =)]) 705 | (let loop ([list (! list)]) 706 | (cond [(null? list) list] 707 | [(not (pair? list)) 708 | (error name "not a proper list: ~e" list)] 709 | [(!*app = item (car list)) (cdr list)] 710 | [else (cons (car list) (~ (loop (! (cdr list)))))])))) 711 | (define* remove 712 | (case-lambda [(item list ) (do-remove 'remove item list ~equal?)] 713 | [(item list =) (do-remove 'remove item list =)])) 714 | (define* (remq item list) (do-remove 'remq item list ~eq?)) 715 | (define* (remv item list) (do-remove 'remv item list ~eqv?)) 716 | 717 | (define (do-remove* name items list =) 718 | (let ([= (! =)] [items (!list items)]) 719 | (let loop ([list (! list)]) 720 | (cond [(null? list) list] 721 | [(not (pair? list)) 722 | (error name "not a proper list: ~e" list)] 723 | [else 724 | (let ([xs (~ (loop (! (cdr list))))]) 725 | (if (memf (lambda (item) (!*app = item (car list))) items) 726 | xs 727 | (cons (car list) xs)))])))) 728 | (define* remove* 729 | (case-lambda [(items list ) (do-remove* 'remove* items list ~equal?)] 730 | [(items list =) (do-remove* 'remove* items list =)])) 731 | (define* (remq* items list) (do-remove* 'remq* items list ~eq?)) 732 | (define* (remv* items list) (do-remove* 'remv* items list ~eqv?)) 733 | 734 | (define* (memf pred list) 735 | (let ([pred (! pred)]) 736 | (let loop ([list (! list)]) 737 | (cond [(null? list) #f] 738 | [(not (pair? list)) (error 'memf "not a proper list: ~e" list)] 739 | [(! (!*app pred (car list))) list] 740 | [else (loop (! (cdr list)))])))) 741 | 742 | (define* (findf pred list) 743 | (~car (memf pred list))) 744 | 745 | (define* (assf pred alist) 746 | (let ([pred (! pred)]) 747 | (let loop ([alist (! alist)]) 748 | (cond [(null? alist) #f] 749 | [(not (pair? alist)) (error 'assf "not a proper list: ~e" alist)] 750 | [else (let ([cell (! (car alist))]) 751 | (cond [(not (pair? cell)) 752 | (error 'assf "non-pair found in list: ~e" cell)] 753 | [(!*app pred (car cell)) cell] 754 | [else (loop (! (cdr alist)))]))])))) 755 | 756 | (define* (filter pred list) 757 | (let ([pred (! pred)]) 758 | (let loop ([list (! list)]) 759 | (cond [(null? list) list] 760 | [(pair? list) 761 | (let ([x (car list)] 762 | [xs (~ (loop (! (cdr list))))]) 763 | (if (! (!*app pred x)) (cons x xs) xs))] 764 | [else (error 'filter "not a proper list: ~e" list)])))) 765 | 766 | (require (only-in racket/base [sort !sort])) 767 | (define* (sort list less?) 768 | (let ([less? (! less?)]) 769 | (!sort (!list list) (lambda (x y) (! (!*app less? x y)))))) 770 | 771 | ;; -------------------------------------------------------------------------- 772 | ;; mzlib/etc functionality 773 | 774 | (require (only-in racket/bool boolean=? symbol=?)) 775 | (define* true #t) 776 | (define* false #f) 777 | 778 | (define* (identity x) x) 779 | ;; no need for dealing with multiple values since students don't use them 780 | (define* (compose . fs) 781 | (let ([fs (!list fs)]) 782 | (cond [(null? fs) identity] 783 | [(null? (cdr fs)) (car fs)] 784 | [else (let ([fs (reverse fs)]) 785 | (lambda xs 786 | (let loop ([fs (cdr fs)] 787 | [x (~!apply (car fs) xs)]) 788 | (if (null? fs) 789 | x 790 | (loop (cdr fs) (~!app (car fs) x))))))]))) 791 | 792 | (define* (build-list n f) 793 | (let ([n (! n)] [f (! f)]) 794 | (unless (exact-nonnegative-integer? n) 795 | (error 'build-list "~s must be an exact integer >= 0" n)) 796 | (unless (procedure? f) 797 | (error 'build-list "~s must be a procedure" f)) 798 | (let loop ([i 0]) 799 | (if (>= i n) 800 | '() 801 | (cons (~ (f i)) (~ (loop (add1 i)))))))) 802 | 803 | ;; -------------------------------------------------------------------------- 804 | ;; Provide everything except some renamed stuff 805 | 806 | (define-syntax (provide-strict-names stx) 807 | #`(provide #,@strict-names)) 808 | (provide-strict-names) 809 | 810 | (define-syntax (renaming-provide stx) 811 | (syntax-case stx () 812 | [(_ id ...) 813 | (with-syntax 814 | ([(~id ...) 815 | (map (lambda (id) 816 | (let* ([str (symbol->string (syntax-e id))] 817 | [~id (string->symbol (string-append "~" str))]) 818 | (datum->syntax id ~id id))) 819 | (syntax->list #'(id ...)))]) 820 | #'(provide (except-out (all-from-out racket/base) module #%app apply #%top λ 821 | id ...) 822 | (rename-out [~id id] ...)))])) 823 | (renaming-provide 824 | lambda define let let* letrec parameterize 825 | values define-values let-values let*-values letrec-values make-struct-type 826 | cons list list* vector box 827 | if and or begin begin0 when unless 828 | set! set-mcar! set-mcdr! vector-set! set-box! 829 | cond case error printf fprintf display write print 830 | eq? eqv? equal? 831 | list? length list-ref list-tail append map for-each andmap ormap 832 | member memq memv assoc assq assv reverse 833 | caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar 834 | caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr 835 | cddaar cddadr cdddar cddddr) 836 | 837 | (provide 838 | ;; multiple values (see above) 839 | split-values 840 | ;; explicit strict/lazy calls 841 | strict-call lazy-call 842 | ;; `list' stuff 843 | first second third fourth fifth sixth seventh eighth rest cons? empty empty? 844 | foldl foldr remove remq remv remove* remq* remv* memf findf assf filter 845 | sort 846 | ;; `etc' stuff 847 | true false boolean=? symbol=? identity compose build-list 848 | ;; extra stuff for lazy Scheme 849 | take cycle) 850 | 851 | 852 | #| 853 | ;; Some tests 854 | (cadr (list (/ 1 0) 1 (/ 1 0))) -> 1 855 | (foldl + 0 '(1 2 3 4)) -> 10 856 | (foldl (lambda (x y) y) 0 (list (/ 1 0) (/ 2 0) (/ 3 0))) -> 0 857 | (foldl (lambda (x y) y) 0 (cons (/ 1 0) (cons (/ 2 0) '()))) -> 0 858 | (foldr + 0 '(1 2 3 4)) -> 10 859 | (foldr (lambda (x y) y) 0 (list (/ 1 0) (/ 2 0) (/ 3 0))) -> 0 860 | (foldr (lambda (x y) y) 0 (cons (/ 1 0) (cons (/ 2 0) '()))) -> 0 861 | (define ones (cons 1 ones)) 862 | (take 5 (foldr cons '() ones)) -> (1 1 1 1 1) 863 | (define a (list (/ 1 0) 2 (/ 3 0))) 864 | (caadr (map list a)) -> 2 865 | (cadr (map + a a)) -> 4 866 | (andmap even? '(1 2 3 4)) -> #f 867 | (ormap even? '(1 2 3 4)) -> #t 868 | (ormap even? '(1 21 3 41)) -> #f 869 | (andmap even? (list 1 2 3 (/ 4 0))) -> #f 870 | |# 871 | -------------------------------------------------------------------------------- /base/lang/reader.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp syntax/module-reader 2 | lazy/base -------------------------------------------------------------------------------- /force.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/promise (for-syntax racket/base)) 4 | 5 | (provide (all-defined-out)) 6 | 7 | (define-syntax ~ (make-rename-transformer #'lazy)) 8 | (define ! force) 9 | (define ~? promise?) 10 | 11 | ;; force a top-level list structure; works with improper lists (will force the 12 | ;; dotted item when it checks if it's a pair); does not handle cycles 13 | (define (!list x) 14 | (let ([x (! x)]) 15 | (if (list? x) ; cheap check, 16 | x ; and big savings on this case 17 | (let loop ([x x]) 18 | (if (pair? x) 19 | ;; avoid allocating when possible 20 | (let ([r (loop (! (cdr x)))]) (if (eq? r (cdr x)) x (cons (car x) r))) 21 | x))))) 22 | 23 | ;; similar to !list, but also force the values in the list 24 | (define (!!list x) 25 | (let ([x (! x)]) 26 | (if (list? x) ; cheap check, 27 | (if (ormap ~? x) (map ! x) x) ; and big savings on these cases 28 | (let loop ([x x]) 29 | (if (pair? x) 30 | ;; avoid allocating when possible 31 | (if (~? (car x)) 32 | (cons (! (car x)) (loop (! (cdr x)))) 33 | (let ([r (loop (! (cdr x)))]) 34 | (if (eq? r (cdr x)) x (cons (car x) r)))) 35 | x))))) 36 | 37 | (define (!! x) 38 | ;; Recursively force the input value, preserving sharing (usually indirectly 39 | ;; specified through self-referential promises). The result is a copy of the 40 | ;; input structure, where the scan goes down the structure that 41 | ;; `make-reader-graph' handles. 42 | (define t (make-weak-hasheq)) 43 | (define placeholders? #f) 44 | (define (loop x) 45 | (let ([x (! x)]) 46 | ;; * Save on placeholder allocation (which will hopefully save work 47 | ;; recopying values again when passed through `make-reader-graph') -- 48 | ;; basic idea: scan the value recursively, marking values as visited 49 | ;; *before* we go inside; when we get to a value that was marked, 50 | ;; create a placeholder and use it as the mark (or use the mark value 51 | ;; if it's already a placeholder); finally, if after we finished 52 | ;; scanning a value -- if we see that its mark was changed to a 53 | ;; placeholder, then put the value in it. 54 | ;; * Looks like we could modify the structure if it's mutable instead of 55 | ;; copying it, but that might leave the original copy with a 56 | ;; placeholder in it. 57 | (define-syntax-rule (do-value expr) 58 | (let ([y (hash-ref t x #f)]) 59 | (cond ;; first visit to this value 60 | [(not y) (hash-set! t x #t) 61 | (let* ([r expr] [y (hash-ref t x #f)]) 62 | (when (placeholder? y) 63 | (placeholder-set! y r) 64 | (set! placeholders? #t)) 65 | r)] 66 | ;; already visited it twice => share the placeholder 67 | [(placeholder? y) y] 68 | ;; second visit => create a placeholder request 69 | [else (let ([p (make-placeholder #f)]) (hash-set! t x p) p)]))) 70 | ;; deal with only with values that `make-reader-graph' can handle (for 71 | ;; example, no mpairs) -- otherwise we can get back placeholder values 72 | ;; (TODO: hash tables) 73 | (cond [(pair? x) 74 | (do-value (cons (loop (car x)) (loop (cdr x))))] 75 | [(vector? x) 76 | (do-value (let* ([len (vector-length x)] [v (make-vector len)]) 77 | (for ([i (in-range len)]) 78 | (vector-set! v i (loop (vector-ref x i)))) 79 | (if (immutable? x) (vector->immutable-vector v) v)))] 80 | [(box? x) 81 | (do-value ((if (immutable? x) box-immutable box) 82 | (loop (unbox x))))] 83 | [else 84 | (let ([k (prefab-struct-key x)]) 85 | (if k 86 | (do-value (let ([v (struct->vector x)]) 87 | (for ([i (in-range 1 (vector-length v))]) 88 | (vector-set! v i (loop (vector-ref v i)))) 89 | (apply make-prefab-struct k 90 | (cdr (vector->list v))))) 91 | x))]))) 92 | (let ([x (loop x)]) (if placeholders? (make-reader-graph x) x))) 93 | -------------------------------------------------------------------------------- /info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection "lazy") 4 | 5 | (define scribblings '(("lazy.scrbl" () (experimental 50)))) 6 | 7 | ;; STC 2010-06-01 8 | ;; Changing lazy to be a tools-based language so I can use 9 | ;; stepper-language-interface to add a stepper button. This change is temporary 10 | ;; until the stepper works with #lang languages. 11 | 12 | ;(require string-constants) 13 | ;(define name "Lazy Scheme") 14 | ;(define drscheme-language-modules '(("lazy.rkt" "lazy"))) 15 | ;(define drscheme-language-positions 16 | ; `((,(string-constant experimental-languages) "Lazy Racket"))) 17 | ;(define drscheme-language-numbers '((1000 -500))) 18 | ;(define drscheme-language-one-line-summaries '("Lazy Racket")) 19 | 20 | (define drracket-tools '(("lazy-tool.rkt"))) 21 | (define drracket-tool-names '("Lazy Racket")) 22 | (define deps '("base" 23 | "drracket-plugin-lib" 24 | "htdp-lib" 25 | "string-constants-lib" 26 | "compatibility-lib")) 27 | (define build-deps '("mzscheme-doc" 28 | "scheme-lib" 29 | "eli-tester" 30 | "racket-doc" 31 | "scribble-lib")) 32 | 33 | (define pkg-desc "The implementation of the Lazy Racket language") 34 | 35 | (define pkg-authors '(eli stchang)) 36 | 37 | (define license 38 | '(Apache-2.0 OR MIT)) 39 | -------------------------------------------------------------------------------- /lang/reader.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp syntax/module-reader 2 | lazy 3 | -------------------------------------------------------------------------------- /lazy-tool.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/unit 4 | racket/class 5 | string-constants 6 | drracket/tool 7 | lang/stepper-language-interface) 8 | 9 | (provide tool@) 10 | 11 | (define tool@ 12 | (unit 13 | (import drracket:tool^) 14 | (export drracket:tool-exports^) 15 | 16 | (define (stepper-settings-language %) 17 | (if (implementation? % stepper-language<%>) 18 | (class* % (stepper-language<%>) 19 | (init-field stepper:supported) 20 | (init-field stepper:enable-let-lifting) 21 | (init-field stepper:show-lambdas-as-lambdas) 22 | (define/override (stepper:supported?) 23 | stepper:supported) 24 | (define/override (stepper:enable-let-lifting?) 25 | stepper:enable-let-lifting) 26 | (define/override (stepper:show-lambdas-as-lambdas?) 27 | stepper:show-lambdas-as-lambdas) 28 | (super-new)) 29 | (class* % () 30 | (init stepper:supported) 31 | (init stepper:enable-let-lifting) 32 | (init stepper:show-lambdas-as-lambdas) 33 | (super-new)))) 34 | 35 | ; extends class implementing module-based-language<%> to use different 36 | ; default-settings, ie, 'constructor printing-style instead of 'print 37 | (define (module-based-language-extension %) 38 | (class* % () 39 | (define/override (default-settings) 40 | (drracket:language:make-simple-settings 41 | #t ; case sensitive 42 | 'constructor ; printing-style 43 | 'mixed-fraction-e ; fraction-style 44 | #f ; show-sharing 45 | #t ; insert-newlines 46 | 'none)) ; annotations 47 | (define/override (default-settings? s) 48 | (and (super default-settings? s) 49 | (eq? (drracket:language:simple-settings-printing-style s) 50 | 'constructor))) 51 | ; (equal? (drracket:language:simple-settings->vector s) 52 | ; (drracket:language:simple-settings->vector (default-settings)))) 53 | (super-new))) 54 | 55 | (define (phase1) (void)) 56 | 57 | ;; phase2 : -> void 58 | (define (phase2) 59 | 60 | (define lazy-language% 61 | (stepper-settings-language 62 | ((drracket:language:get-default-mixin) 63 | (drracket:language:module-based-language->language-mixin 64 | (module-based-language-extension 65 | (drracket:language:simple-module-based-language->module-based-language-mixin 66 | drracket:language:simple-module-based-language%)))))) 67 | 68 | (drracket:language-configuration:add-language 69 | (instantiate lazy-language% () 70 | (one-line-summary "Lazy Racket") 71 | (module '(lib "lazy/lazy.rkt")) 72 | (language-position `(,(string-constant experimental-languages) 73 | "Lazy Racket")) 74 | (language-numbers '(1000 -500)) 75 | (stepper:supported #t) 76 | (stepper:enable-let-lifting #t) 77 | (stepper:show-lambdas-as-lambdas #t))) 78 | ))) 79 | -------------------------------------------------------------------------------- /lazy.rkt: -------------------------------------------------------------------------------- 1 | #lang lazy/base 2 | 3 | (require (except-in lazy/list 4 | take)) 5 | (provide (all-from-out lazy/base 6 | lazy/list)) 7 | -------------------------------------------------------------------------------- /lazy.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | @(require (for-label (except-in lazy) 3 | (only-in lazy/force ! !! !list !!list) 4 | racket/contract 5 | (only-in racket/promise promise?))) 6 | 7 | @(define-syntax-rule (deflazy mod def id) 8 | (begin 9 | (def-mz-req mod id mz-id) 10 | @def[id]{Lazy variant of @|mz-id|.})) 11 | 12 | @(define-syntax-rule (def-mz-req mod id in-mz-id) 13 | (begin 14 | (define-syntax-rule (intro mz-id) 15 | (begin 16 | (require (for-label (only-in mod id))) 17 | (define mz-id (racket id)))) 18 | (intro in-mz-id))) 19 | 20 | @(define-syntax-rule (defprocthing* mod id ...) 21 | (begin 22 | (deflazy mod defprocthing id) 23 | ...)) 24 | 25 | @(define-syntax-rule (defprocthing id . rest) 26 | (defthing id procedure? . rest)) 27 | 28 | @(define-syntax-rule (defidform* mod id ...) 29 | (begin 30 | (deflazy mod defidform id) 31 | ...)) 32 | 33 | @; ---------------------------------------- 34 | 35 | @(require scribble/manual) 36 | 37 | @title{Lazy Racket} 38 | 39 | @author["Eli Barzilay"] 40 | 41 | @defmodulelang[lazy] 42 | 43 | Lazy Racket is available as both a language level and a module that 44 | can be used to write lazy code. To write lazy code, simply use 45 | @racketmodname[lazy] as your module's language: 46 | 47 | @racketmod[ 48 | lazy 49 | ... @#,elem{lazy code here}...] 50 | 51 | Function applications are delayed, and promises are automatically 52 | forced. The language provides bindings that are equivalent to most of 53 | the @racketmodname[racket/base] and @racketmodname[racket/list] 54 | libraries. Primitives are strict in the expected places; struct 55 | constructors are lazy; @racket[if], @racket[and], @racket[or] @|etc| 56 | are plain (lazy) functions. Strict functionality is provided as-is: 57 | @racket[begin], I/O, mutation, parameterization, etc. To have your 58 | code make sense, you should chain side effects in @racket[begin]s, 59 | which will sequence things properly. (Note: This is similar to 60 | threading monads through your code---only use @racket[begin] where 61 | order matters.) 62 | 63 | Mixing lazy and strict code is simple: you just write the lazy code in 64 | the lazy language, and strict code as usual. The lazy language treats 65 | imported functions (those that were not defined in the lazy language) 66 | as strict, and on the strict side you only need to force (possibly 67 | recursively) through promises. 68 | 69 | A few side-effect bindings are provided as-is. For example, 70 | @racket[read] and @racket[printf] do the obvious thing---but note that 71 | the language is a call-by-need, and you need to be aware when promises 72 | are forced. There are also bindings for @racket[begin] (delays a 73 | computation that forces all sub-expressions), @racket[when], 74 | @racket[unless], etc. There are, however, less reliable and might 75 | change (or be dropped) in the future. 76 | 77 | There are a few additional bindings, the important ones are special 78 | forms that force strict behaviour---there are several of these that 79 | are useful in forcing different parts of a value in different ways, as 80 | described in @secref["forcing"]. 81 | 82 | @; ---------------------------------------- 83 | 84 | @section{Lazy Forms and Functions} 85 | 86 | @defidform*[mzscheme 87 | lambda 88 | define 89 | ] 90 | 91 | @defidform*[scheme 92 | let 93 | let* 94 | letrec 95 | parameterize 96 | define-values 97 | let-values 98 | let*-values 99 | letrec-values 100 | if 101 | set! 102 | begin begin0 when unless 103 | cond case 104 | ] 105 | 106 | @defprocthing*[scheme 107 | values make-struct-type 108 | cons list list* vector box 109 | and or 110 | set-mcar! set-mcdr! vector-set! set-box! 111 | error printf fprintf display write print 112 | eq? eqv? equal? 113 | list? length list-ref list-tail append map for-each andmap ormap 114 | member memq memv assoc assq assv reverse 115 | caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar 116 | caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr 117 | cddaar cddadr cdddar cddddr 118 | first second third fourth fifth sixth seventh eighth rest cons? empty empty? 119 | foldl foldr last-pair remove remq remv remove* remq* remv* memf assf filter 120 | sort 121 | true false boolean=? symbol=? compose build-list 122 | take 123 | ] 124 | 125 | @defprocthing[identity]{Lazy identity function.} 126 | 127 | @defprocthing[cycle]{Creates a lazy infinite list that repeats its 128 | input arguments in order.} 129 | 130 | @; ---------------------------------------- 131 | 132 | @section[#:tag "forcing"]{Forcing Values} 133 | 134 | @defmodule[lazy/force] 135 | 136 | The bindings of @racketmodname[lazy/force] are re-provided by 137 | @racketmodname[lazy]. 138 | 139 | @defproc[(! [expr any/c]) any/c]{ 140 | 141 | Evaluates @racket[expr] strictly. The result is always forced, over 142 | and over until it gets a non-promise value.} 143 | 144 | 145 | @defproc[(!! [expr any/c]) any/c]{ 146 | 147 | Similar to @racket[!], but recursively forces a structure (e.g: 148 | lists).} 149 | 150 | 151 | @defproc[(!list [expr (or/c promise? list?)]) list?]{ 152 | 153 | Forces the @racket[expr] which is expected to be a list, and forces 154 | the @racket[cdr]s recursively to expose a proper list structure.} 155 | 156 | 157 | @defproc[(!!list [expr (or/c promise? list?)]) list?]{ 158 | 159 | Similar to @racket[!list] but also forces (using @racket[!]) the 160 | elements of the list.} 161 | 162 | 163 | @;{ This moved into lazy.rkt, and all the other forces will move there too. 164 | 165 | @subsection{Multiple values} 166 | 167 | To avoid dealing with multiple values, they are treated as a single 168 | tuple in the lazy language. This is implemented as a 169 | @racket[multiple-values] struct, with a @racket[values] slot. 170 | 171 | @defproc[(split-values [x multiple-values?]) any]{ 172 | 173 | Used to split such a tuple to actual multiple values. (This may change 174 | in the future.)} 175 | 176 | 177 | @defproc[(!values [expr (or/c promise? multiple-values?)]) any]{ 178 | 179 | Forces @racket[expr] and uses @racket[split-values] on the result.} 180 | 181 | 182 | @defproc[(!!values [expr (or/c promise? multiple-values?)]) any]{ 183 | 184 | Similar to @racket[!values], but forces each of the values 185 | recursively.} 186 | 187 | ;} 188 | -------------------------------------------------------------------------------- /list.rkt: -------------------------------------------------------------------------------- 1 | #lang lazy/base 2 | 3 | (require 4 | (prefix-in ! racket/list) 5 | (except-in 6 | racket/list 7 | first second third fourth fifth sixth seventh eighth 8 | rest last-pair 9 | make-list 10 | take drop split-at takef dropf splitf-at 11 | take-right drop-right split-at-right takef-right dropf-right splitf-at-right 12 | add-between 13 | append* 14 | flatten 15 | remove-duplicates 16 | filter-map count partition 17 | range 18 | append-map 19 | filter-not 20 | argmin argmax)) 21 | 22 | (provide (all-from-out racket/list) 23 | last-pair 24 | take drop split-at takef dropf splitf-at 25 | take-right drop-right split-at-right takef-right dropf-right splitf-at-right 26 | add-between 27 | append* 28 | flatten 29 | remove-duplicates 30 | filter-map count partition 31 | range 32 | append-map 33 | filter-not 34 | argmin argmax) 35 | 36 | ;; lazy versions of exports from racket/list 37 | ;; --------------------------------------------------------------------------------------------------- 38 | 39 | (define (last-pair p) 40 | (let ([p (! p)]) 41 | (unless (pair? p) 42 | (raise-argument-error 'last-pair "pair?" p)) 43 | (let loop ([p p]) 44 | (define next (! (cdr p))) 45 | (if (pair? next) (loop next) p)))) 46 | 47 | (define (make-list n v) 48 | (let ([n (! n)]) 49 | (unless (exact-nonnegative-integer? n) 50 | (raise-argument-error 'make-list "exact-nonnegative-integer?" 0 n v)) 51 | (let loop ([n n] 52 | [acc '()]) 53 | (if (zero? n) acc 54 | (loop (sub1 n) (cons v acc)))))) 55 | 56 | (define (take l n) 57 | (let ([n (! n)]) 58 | (unless (exact-nonnegative-integer? n) 59 | (raise-argument-error 'take "exact-nonnegative-integer?" 1 l n)) 60 | (let loop ([n n] [l l]) 61 | (if (zero? n) 62 | '() 63 | (let ([l (! l)]) 64 | (cond [(null? l) 65 | ;; it would be fine to force the whole list (since we now 66 | ;; know it's finite), but doing so means keeping a reference 67 | ;; to its head, which can lead to memory leaks. 68 | (raise-arguments-error 'take 69 | "index is too large for input list" 70 | "index" n)] 71 | [(pair? l) (cons (car l) (loop (sub1 n) (! (cdr l))))] 72 | [else (raise-argument-error 'take "list?" l)])))))) 73 | 74 | (define (split-at l n) 75 | (let ([n (! n)]) 76 | (unless (exact-nonnegative-integer? n) 77 | (raise-argument-error 'split-at "exact-nonnegative-integer?" 1 l n)) 78 | (let loop ([n n] [l l]) 79 | (if (zero? n) 80 | (values '() l) 81 | (let ([l (! l)]) 82 | (cond [(null? l) 83 | ;; see comment for `take` 84 | (raise-arguments-error 'split-at 85 | "index is too large for input list" 86 | "index" n)] 87 | [(pair? l) 88 | (define-values (a b) (loop (sub1 n) (! (cdr l)))) 89 | (values (cons (car l) a) b)] 90 | [else (raise-argument-error 'split-at "list?" l)])))))) 91 | 92 | (define (drop lst pos) 93 | (list-tail lst pos)) 94 | 95 | (define (takef lst pred) 96 | (let ([pred (! pred)]) 97 | (unless (procedure? pred) 98 | (raise-argument-error 'takef "procedure?" 1 lst pred)) 99 | (let loop ([lst (! lst)]) 100 | (cond 101 | [(and (pair? lst) (! (pred (car lst)))) 102 | (cons (car lst) (loop (cdr lst)))] 103 | [else '()])))) 104 | 105 | (define (dropf lst pred) 106 | (let ([pred (! pred)]) 107 | (unless (procedure? pred) 108 | (raise-argument-error 'takef "procedure?" 1 lst pred)) 109 | (let loop ([lst (! lst)]) 110 | (cond 111 | [(and (pair? lst) (! (pred (car lst)))) 112 | (loop (cdr lst))] 113 | [else lst])))) 114 | 115 | (define (splitf-at lst pred) 116 | (let ([pred (! pred)]) 117 | (unless (procedure? pred) 118 | (raise-argument-error 'takef "procedure?" 1 lst pred)) 119 | (let loop ([lst (! lst)]) 120 | (cond 121 | [(and (pair? lst) (! (pred (car lst)))) 122 | (define-values (a b) (loop (cdr lst))) 123 | (values (cons (car lst) a) b)] 124 | [else (values '() lst)])))) 125 | 126 | (define (take-right l n) 127 | (drop l (- (improper-length l) n))) 128 | 129 | (define (drop-right l n) 130 | (take l (- (improper-length l) n))) 131 | 132 | (define (split-at-right l n) 133 | (split-at l (- (improper-length l) n))) 134 | 135 | (define (takef-right l pred) 136 | (improper-reverse (takef (improper-reverse l) pred))) 137 | 138 | (define (dropf-right l pred) 139 | (improper-reverse (dropf (improper-reverse l) pred))) 140 | 141 | (define (splitf-at-right l pred) 142 | (improper-reverse (splitf-at (improper-reverse l) pred))) 143 | 144 | ;; keyword arguments currently do not work to due Lazy Racket limitations 145 | (define (add-between lst v 146 | #:before-first [before-first '()] 147 | #:before-last [before-last v] 148 | #:after-last [after-last '()] 149 | #:splice? [splice? #f]) 150 | (define middle 151 | (let ([lst (!list lst)]) 152 | (cons (car lst) 153 | (let loop ([lst (cdr lst)]) 154 | (cond 155 | [(null? lst) '()] 156 | [else ((if splice? append list*) 157 | (if (null? (cdr lst)) before-last v) 158 | (if splice? (list (car lst)) (car lst)) 159 | (loop (cdr lst)))]))))) 160 | (if splice? 161 | (append before-first middle after-last) 162 | middle)) 163 | 164 | (define (append* . args) 165 | (define-values (head tail) (split-at-right args 1)) 166 | (apply append (append head (apply append tail)))) 167 | 168 | (define (flatten v) 169 | (let ([v (! v)]) 170 | (cond 171 | [(pair? v) (append (flatten (car v)) (flatten (cdr v)))] 172 | [(null? v) '()] 173 | [else (list v)]))) 174 | 175 | (define (remove-duplicates lst [same? equal?] #:key [extract-key (λ (x) x)]) 176 | (let loop ([lst (!list lst)]) 177 | (if (null? lst) '() 178 | (cons (car lst) (loop (remove* (list (car lst)) lst 179 | (λ (a b) (same? (extract-key a) (extract-key b))))))))) 180 | 181 | (define (filter-map proc lst . lsts) 182 | (let loop ([lsts (cons lst lsts)]) 183 | (cond 184 | [(null? (! (car lsts))) '()] 185 | [else 186 | (define result (apply proc (map car lsts))) 187 | (if result 188 | (cons result (loop (map cdr lsts))) 189 | (loop (map cdr lsts)))]))) 190 | 191 | (define (count proc lst . lsts) 192 | (let loop ([lsts (cons lst lsts)] 193 | [acc 0]) 194 | (cond 195 | [(null? (! (car lsts))) acc] 196 | [else 197 | (define result (apply proc (map car lsts))) 198 | (loop (map cdr lsts) (if result (add1 acc) acc))]))) 199 | 200 | (define (partition pred lst) 201 | (let loop ([lst (!list lst)]) 202 | (cond 203 | [(null? lst) (values '() '())] 204 | [else 205 | (define-values (a b) (loop (cdr lst))) 206 | (if (pred (car lst)) 207 | (values (cons (car lst) a) b) 208 | (values a (cons (car lst) b)))]))) 209 | 210 | (define range 211 | (case-lambda 212 | [(end) (range 0 end)] 213 | [(start end) (range start end 1)] 214 | [(start end step) 215 | (let loop ([n start]) 216 | (cond 217 | [(if (positive? step) 218 | (n . >= . end) 219 | (n . <= . end)) '()] 220 | [else 221 | (cons n (loop (+ n step)))]))])) 222 | 223 | (define (append-map proc lst . lsts) 224 | (append* (apply map proc lst lsts))) 225 | 226 | (define (filter-not pred lst) 227 | (filter (λ (x) (not (pred x))) lst)) 228 | 229 | (define (argmin proc lst) 230 | (!argmin proc (!list lst))) 231 | 232 | (define (argmax proc lst) 233 | (!argmax proc (!list lst))) 234 | 235 | ;; internal utility functions 236 | ;; --------------------------------------------------------------------------------------------------- 237 | 238 | (define (improper-length lst) 239 | (let loop ([n 0] [lst (! lst)]) 240 | (cond 241 | [(pair? lst) (loop (add1 n) (! (cdr lst)))] 242 | [else n]))) 243 | 244 | (define (improper-reverse lst) 245 | (let loop ([lst (! lst)] 246 | [acc '()]) 247 | (cond 248 | [(pair? lst) (loop (! (cdr lst)) (cons (car lst) acc))] 249 | [else acc]))) 250 | -------------------------------------------------------------------------------- /main.rkt: -------------------------------------------------------------------------------- 1 | (module main "lazy.rkt" 2 | (provide (all-from-out "lazy.rkt"))) 3 | -------------------------------------------------------------------------------- /tests/forcers.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require tests/eli-tester lazy/force) 4 | 5 | (define (test-lazy/force) 6 | (test (! 1) => 1 7 | (! (! 1)) => 1 8 | (! (~ 1)) => 1 9 | (! (~ (~ (~ 1)))) => 1)) 10 | 11 | (define (test-!list) 12 | (test (!list (list 1 2 3)) => '(1 2 3) 13 | (!list (~ (list 1 2 3))) => '(1 2 3) 14 | (!list (~ (cons 1 (~ (cons 2 (~ (cons 3 (~ null)))))))) => '(1 2 3) 15 | (!list 1) => 1 ; works on dotted lists 16 | (!list (cons 1 2)) => '(1 . 2))) 17 | 18 | (define (test-!!list) 19 | (test (!!list (list 1 2 3)) => '(1 2 3) 20 | (!!list (list (~ 1) (~ 2) (~ 3))) => '(1 2 3) 21 | (!!list (list* (~ 1) (~ 2) (~ 3))) => '(1 2 . 3) 22 | (!!list (~ (cons (~ 1) (~ (cons (~ 2) (~ (cons (~ 3) (~ null)))))))) 23 | => '(1 2 3) 24 | (!!list (~ (cons (~ 1) (~ (list 2 3))))) => '(1 2 3) 25 | (!!list (~ (cons (~ 1) (~ (list 2 (~ 3)))))) => '(1 2 3))) 26 | 27 | (define (test-!!) 28 | (parameterize ([print-graph #t]) 29 | (test 30 | (!! (~ (cons (~ 1) (~ (cons (~ 2) (~ (cons (~ 3) (~ null)))))))) 31 | => '(1 2 3) 32 | (format "~s" (!! (letrec ([ones (~ (cons 1 (~ ones)))]) ones))) 33 | => "#0=(1 . #0#)" 34 | (format "~s" (!! (letrec ([ones (~ (cons 1 (~ ones)))]) (list ones ones)))) 35 | => "(#0=(1 . #0#) #0#)" 36 | (format "~s" (!! (letrec ([x (vector 1 (~ x))]) x))) 37 | => "#0=#(1 #0#)" 38 | (format "~s" (!! (letrec ([x (vector-immutable 1 (~ x))]) x))) 39 | => "#0=#(1 #0#)" 40 | (format "~s" (!! (letrec ([x (box (~ x))]) x))) 41 | => "#0=#�#" 42 | (format "~s" (!! (letrec ([x (box-immutable (~ x))]) x))) 43 | => "#0=#�#" 44 | (format "~s" (!! (letrec ([x (make-prefab-struct 'foo 1 (~ x))]) x))) 45 | => "#0=#s(foo 1 #0#)"))) 46 | 47 | (provide forcer-tests) 48 | (module+ main (forcer-tests)) 49 | (define (forcer-tests) 50 | (test do (test-lazy/force) 51 | do (test-!list) 52 | do (test-!!list) 53 | do (test-!!))) 54 | -------------------------------------------------------------------------------- /tests/lang.rkt: -------------------------------------------------------------------------------- 1 | #lang lazy 2 | 3 | (require tests/eli-tester) 4 | 5 | ;; tests for lazy language constructs 6 | 7 | (define (basic-tests) 8 | (test 9 | (! ((car (list if)) (< 1 2) 3 (error "poof"))) => 3 10 | (! ((car (list or)) 3 (error "poof"))) => 3 11 | (! ((car (list and)) (< 2 1) (error "poof"))) => #f 12 | (!! (let ([x 0]) (set! x 1) (list x))) => '(1) ; implicit begin forces 13 | (! (let () (define f 1) ((λ (x) x) f))) => 1 14 | (! (let ([x 0]) (when (zero? x) (error "poof")) 1)) =error> "poof" 15 | (! (let ([x 0]) (when (zero? x) (set! x (add1 x)) (set! x (add1 x))) x)) 16 | => 2 17 | (! (let ([x 1]) (unless (zero? x) (set! x (add1 x)) (set! x (add1 x))) x)) 18 | => 3 19 | (! (let ([x 0]) (cond [(zero? x) (set! x (add1 x)) (set! x (add1 x))]) x)) 20 | => 2 21 | (! (eq? 1 1)) => #t 22 | (! (eq? 1 2)) => #f 23 | (! (eqv? 1.0 1.0)) => #t 24 | (! (eqv? 1.0 1)) => #f 25 | (! (= 1.0 1)) => #t 26 | (! (equal? (list 1.0) (list 1.0))) => #t 27 | (! (letrec ([zs (cons 0 zs)]) (equal? (list zs zs) (list zs zs)))) => #t 28 | )) 29 | 30 | (define (list-tests) 31 | (test 32 | (! (car 0)) =error> #rx"car: contract violation\n expected: pair?|0 is not a pair" 33 | (! (cdr 0)) =error> #rx"cdr: contract violation\n expected: pair?|0 is not a pair" 34 | (! (car (cons 1 (/ 1 0)))) => 1 35 | (! (cdr (cons (/ 1 0) 1))) => 1 36 | (! (list-ref (list (/ 1 0) 1 (/ 1 0)) 1)) => 1 37 | (! (list-ref (cons 1 (/ 1 0)) 0)) => 1 ; doesn't force list structure 38 | (! (list-tail (cons (/ 1 0) 0) 1)) => 0 39 | (! (length (list (/ 1 0) (/ 1 0) (/ 1 0)))) => 3 40 | (! (let ([l (list (/ 1 0) (/ 1 0))]) (length (append l l l)))) => 6 41 | (!! (member 1 (cons 0 (cons 1 2)))) => '(1 . 2) 42 | (!! (memq 1 (cons 0 (cons 1 2)))) => '(1 . 2) 43 | (!! (memv 1 (cons 0 (cons 1 2)))) => '(1 . 2) 44 | (! (second (map car (list 1 2 3)))) =error> #rx"contract violation|not a pair" 45 | (! (second (map car (list 1 '(2) 3)))) => 2 46 | )) 47 | 48 | (define (take-tests) 49 | (define test-lst1 '(1 2 3)) 50 | (test 51 | (! (take "nonnum" test-lst1)) 52 | =error> 53 | #rx"take.*expect.*type .*given: \"nonnum\"; other arguments.*1 2 3" 54 | (! (take -1 test-lst1)) 55 | =error> #rx"take.*expect.*type .*given: -1" 56 | (! (take -1 "nonlist")) 57 | =error> #rx"take.*expect.*type .*given: -1" 58 | (! (take 0 "nonlist")) => '() 59 | (! (take 1 "nonlist")) =error> "take: not a proper list: \"nonlist\"" 60 | (! (take 0 null)) => '() 61 | (! (take 0 test-lst1)) => '() 62 | (!! (take 1 test-lst1)) => '(1) 63 | (!! (take 2 test-lst1)) => '(1 2) 64 | (!! (take 3 (take 4 test-lst1))) => '(1 2 3) ; doesn't force the error 65 | (! (fourth (take 4 test-lst1))) ; this one does 66 | =error> "take: index 4 too large for input list" 67 | (! (list-ref (take (~ 1) (list 2)) 0)) => 2 68 | (! (take 0 (error))) => '() ; doesn't even force the list structure 69 | (!! (take 1 (cons 0 (error "poof")))) => '(0) 70 | )) 71 | 72 | (define (misc-tests) 73 | (define-struct a (b c)) 74 | (define-struct d (e f)) 75 | (test 76 | (! (a-b (make-a 1 2))) => 1 77 | (! (a-c (make-a 1 2))) => 2 78 | (! (a-b (a 1 2))) => 1 79 | (! (a-c (a 1 2))) => 2 80 | (! (a? (a 1 2))) => true 81 | (! (a? (d 1 2))) => false 82 | )) 83 | 84 | ; Lazy Racket examples from Premiers cours de programmation avec Scheme (Roy) 85 | (define (pcps-tests) 86 | ;; Definitions -------------------------------------------------------------- 87 | (define (f x y) x) 88 | (define (fac n) 89 | (if (= n 0) 1 (* n (fac (- n 1))))) 90 | (define (new-if test p q) 91 | (cond (test p) 92 | (else q))) 93 | (define fibs (cons 0 (cons 1 (map + fibs (cdr fibs))))) 94 | #;(define ($list-ref L k) 95 | (let loop ((k (force k)) (L (force L))) 96 | (if (= k 0) 97 | (car L) 98 | (loop (- k 1) (cdr (force L)))))) 99 | (define L2 (cons 2 (map add1 L2))) 100 | (define (rayer n L) ; L prive des multiples de n 101 | (filter (lambda (x) (not (= 0 (modulo x n)))) L)) 102 | (define (crible L) 103 | (cons (car L) (crible (rayer (car L) (cdr L))))) 104 | (define PREMS (crible L2)) ; primes 105 | (define ZERO (cons 0 ZERO)) ; le flot infini <0,0,0,0,...> 106 | (define (poly->serie L) ; L = coeffs en puissances croissantes 107 | (define (copy L) 108 | (if (null? L) 109 | ZERO ; padding à droite par des 0 110 | (cons (car L) (copy (cdr L))))) 111 | (copy L)) 112 | (define (int-serie S) ; integration terme a terme 113 | (define (aux S i) 114 | (cons (/ (car S) i) (aux (cdr S) (+ i 1)))) 115 | (aux S 1)) 116 | (define EXPO (cons 1 (int-serie EXPO))) 117 | (define SIN (cons 0 (int-serie COS))) 118 | (define COS (cons 1 (map - (int-serie SIN)))) 119 | (define (ints-from n) 120 | (cons n (ints-from (+ n 1)))) 121 | (define NAT (ints-from 0)) 122 | (define UN (cons 1 UN)) 123 | (define nats (cons 0 (map + nats UN))) 124 | (define QUATRE (filter (lambda (x) (zero? (modulo x 4))) NAT)) 125 | (define (melanger F1 F2) ; F1 et F2 infinis strictement croissants 126 | (cond ((< (car F1) (car F2)) (cons (car F1) (melanger (cdr F1) F2))) 127 | ((> (car F1) (car F2)) (cons (car F2) (melanger F1 (cdr F2)))) 128 | (else (cons (car F1) (melanger (cdr F1) (cdr F2)))))) 129 | (define (zoom x F) 130 | (cons (* (car F) x) (zoom x (cdr F)))) 131 | (define PAIR (zoom 2 NAT)) 132 | (define (hamming) 133 | (define h (cons 1 (melanger (zoom 2 h) (melanger (zoom 3 h) (zoom 5 h))))) 134 | h) 135 | (define h (hamming)) 136 | (define FACT (cons 1 (map * FACT (cdr NAT)))) 137 | (define (entrelacer s1 s2) 138 | (cons (car s1) (entrelacer s2 (cdr s1)))) 139 | (define F (entrelacer NAT F)) 140 | ;; Tests -------------------------------------------------------------------- 141 | (test 142 | (!! (fac 5)) => 120 143 | (!! (new-if (= 1 2) (/ 1 0) 3)) => 3 144 | (!! (take 20 PREMS)) => 145 | '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71) 146 | (!! (list-ref PREMS 999)) => 7919 147 | (!! (apply + (take 100 PREMS))) => 24133 148 | (!! (take 10 (poly->serie '(1 2 3)))) => '(1 2 3 0 0 0 0 0 0 0) 149 | (!! (take 10 EXPO)) => 150 | '(1 1 1/2 1/6 1/24 1/120 1/720 1/5040 1/40320 1/362880) 151 | (!! (take 8 SIN)) => '(0 1 0 -1/6 0 1/120 0 -1/5040) 152 | (!! (take 8 COS)) => '(1 0 -1/2 0 1/24 0 -1/720 0) 153 | (!! (take 10 (ints-from 5))) => '(5 6 7 8 9 10 11 12 13 14) 154 | (!! (take 10 NAT)) => '(0 1 2 3 4 5 6 7 8 9) 155 | (!! (take 10 UN)) => '(1 1 1 1 1 1 1 1 1 1) 156 | (!! (take 10 nats)) => '(0 1 2 3 4 5 6 7 8 9) 157 | (!! (take 10 QUATRE)) => '(0 4 8 12 16 20 24 28 32 36) 158 | (!! (take 10 (melanger NAT QUATRE))) => '(0 1 2 3 4 5 6 7 8 9) 159 | (!! (take 10 PAIR)) => '(0 2 4 6 8 10 12 14 16 18) 160 | (!! (take 30 h)) => 161 | '(1 2 3 4 5 6 8 9 10 12 15 16 18 20 24 25 27 30 32 36 40 45 48 50 54 60 64 72 75 80) 162 | (!! (list-ref h 10000)) => 288555831593533440 163 | (!! (take 10 FACT)) => '(1 1 2 6 24 120 720 5040 40320 362880) 164 | (!! (take 10 (entrelacer NAT PAIR))) => '(0 0 1 2 2 4 3 6 4 8) 165 | (!! (take 10 F)) => '(0 0 1 0 2 1 3 0 4 2))) 166 | 167 | (define (strictness-tests) 168 | ; function used in tests for curried functions defined with 169 | ; the shorthand syntax 170 | (define (((iffn cond) iftrue) iffalse) 171 | (if cond iftrue iffalse)) 172 | (test 173 | (! (and (/ 1 0))) =error> "/: division by zero" 174 | (! (and #f (/ 1 0))) => #f 175 | (! (and #t (/ 1 0))) =error> "/: division by zero" 176 | (! (cdr (append (list (/ 1 0)) '()))) => '() 177 | (! (cdr (append '() (list (/ 1 0))))) => '() 178 | (! (append (/ 1 0) '())) =error> "/: division by zero" 179 | (! (append (/ 1 0) '() '())) =error> "/: division by zero" 180 | (! (append (/ 1 0) '(1))) =error> "/: division by zero" 181 | (! (append '() (/ 1 0))) =error> "/: division by zero" 182 | (! (car (append '(1) (/ 1 0)))) => 1 183 | (! (cdr (append '(1) (/ 1 0)))) =error> "/: division by zero" 184 | (! (car (append '(1) 1 (/ 1 0)))) => 1 185 | (! (foldr (/ 1 0) 0 '())) =error> "/: division by zero" 186 | (! (foldr 1 (/ 1 0) '())) =error> "/: division by zero" 187 | (! (foldr 1 2 (/ 1 0))) =error> "/: division by zero" 188 | (! (foldr (/ 1 0) 1 '(1))) =error> "/: division by zero" 189 | (! (foldr 1 (/ 1 0) '(1))) =error> "/: division by zero" 190 | (! (foldl (/ 1 0) 0 '())) =error> "/: division by zero" 191 | (! (foldl 1 (/ 1 0) '())) =error> "/: division by zero" 192 | (! (foldl 1 2 (/ 1 0))) =error> "/: division by zero" 193 | (! (foldl (/ 1 0) 1 '(1))) =error> "/: division by zero" 194 | (! (foldl 1 (/ 1 0) '(1))) =error> "/: division by zero" 195 | (! (filter (/ 1 0) '())) =error> "/: division by zero" 196 | (! (filter 1 (/ 1 0))) =error> "/: division by zero" 197 | (! (filter (/ 1 0) '(1))) =error> "/: division by zero" 198 | (! (map (/ 1 0) '())) =error> "/: division by zero" 199 | (! (map (/ 1 0) '(1))) =error> "/: division by zero" 200 | (! (map 1 (/ 1 0))) =error> "/: division by zero" 201 | (! (if (/ 1 0) 1 2)) =error> "/: division by zero" 202 | (! (if #t 1 (/ 1 0))) => 1 203 | (! (if #f (/ 1 0) 1)) => 1 204 | (! (andmap (/ 1 0) '())) =error> "/: division by zero" 205 | (! (andmap (/ 1 0) '(1))) =error> "/: division by zero" 206 | (! (andmap 1 (/ 1 0))) =error> "/: division by zero" 207 | (! (((iffn #f) (/ 1 0)) 1)) => 1 208 | (! (((iffn #t) (/ 1 0)) 1)) =error> "/: division by zero" 209 | (! (((iffn #f) 1) (/ 1 0))) =error> "/: division by zero" 210 | (! (((iffn #t) 1) (/ 1 0))) => 1 211 | )) 212 | 213 | (define (values-tests) 214 | (test 215 | ;; Tests from Luke Whittlesey 216 | (! (let-values ([(x) (values (error "a"))]) 1)) => 1 217 | (! (let-values ([(x y) (values (error "a") (error "b"))]) 1)) => 1 218 | (! (let*-values ([(x) (values (error "a"))]) 1)) => 1 219 | (! (let*-values ([(x0 x1) (values (error "a") (error "b"))] [(y) (values x0)]) 1)) => 1 220 | (! (letrec ([x y] [y 1]) x)) =error> "y: undefined" 221 | (! (letrec ([x (list y)] [y 1]) (car x))) => 1 222 | (! (letrec-values ([(x) (values (error "a"))]) 1)) => 1 223 | (! (letrec-values ([(x y) (values (error "a") (error "b"))]) 1)) => 1 224 | (! (letrec-values ([(x) (values (list y))] [(y) (values 1)]) (car x))) => 1 225 | (! (letrec-values ([(x0 x1) (values (list y0) (list y1))] [(y0 y1) (values 1 2)]) 226 | (+ (car x0) (car x1)))) => 3 227 | (! (letrec-values ([(A) (values (list 'a B))] 228 | [(B) (values (list 'b A))]) (car A))) => 'a 229 | (! (letrec-values ([(A) (values (list 'a B))] 230 | [(B) (values (list 'b A))]) (caadr A))) => 'b 231 | (! (letrec-values ([(A) (values (list 'a B))] 232 | [(B) (values (list 'b A))]) (car B))) => 'b 233 | (! (letrec-values ([(A) (values (list 'a B))] 234 | [(B) (values (list 'b A))]) (caadr B))) => 'a 235 | ;; this errors because let-values (and other values-extractors) must force 236 | ;; the rhs (one level down) to extract the values 237 | (let-values ([(x) (error "a")]) 1) =error> "a" 238 | )) 239 | 240 | (provide lang-tests) 241 | (module+ main (lang-tests)) 242 | (define (lang-tests) 243 | (! (begin (basic-tests) 244 | (list-tests) 245 | (take-tests) 246 | (misc-tests) 247 | (pcps-tests) 248 | (strictness-tests) 249 | (values-tests)))) 250 | -------------------------------------------------------------------------------- /tests/main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (module+ test 4 | (require tests/eli-tester "promise.rkt" "forcers.rkt" "lang.rkt" "space.rkt") 5 | 6 | (test do (promise-tests) 7 | do (forcer-tests) 8 | do (lang-tests) 9 | do (space-tests))) 10 | -------------------------------------------------------------------------------- /tests/promise.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; Tests for the various racket promises 4 | 5 | (require racket/promise tests/eli-tester (for-syntax racket/base)) 6 | 7 | ;; check that things are `promise?'s or not 8 | (define (test-types) 9 | (for ([v (list 1 '(1) (lambda () 1))]) 10 | (test (promise? v) => #f)) 11 | (for ([v (list (delay 1) (lazy 1) (delay (delay 1)) (lazy (lazy 1)))]) 12 | (test (promise? v) => #t))) 13 | 14 | (define (test-syntax) 15 | (test (delay) =error> "bad syntax" 16 | (lazy) =error> "bad syntax" 17 | (delay #:foo 1 2) =error> "unrecognized option" 18 | (force (delay/thread #:group #f)) =error> "bad syntax" 19 | (force (delay/thread #:group #f 1)) => 1 20 | (force (delay/thread 1 #:group #f 2)) => 2 21 | (force (delay/thread #:groupie #f 1)) =error> "unrecognized option")) 22 | 23 | ;; basic delay/lazy/force tests 24 | (define (test-basic-promises) 25 | (define thunk1 (lambda () 1)) 26 | (define promise1 (delay 1)) 27 | (define ? #f) 28 | ;; test a few different values 29 | (define-syntax-rule (t (f x ...)) 30 | (begin (set! ? 1) (test (f x ...) => ?) 31 | (set! ? '()) (test (f x ...) => ?) 32 | (set! ? '(1)) (test (f x ...) => ?) 33 | (set! ? thunk1) (test (f x ...) => ?))) 34 | (define-syntax-rule (t* (f x ...)) 35 | (begin (t (f x ...)) (set! ? promise1) (test (f x ...) => ?))) 36 | ;; `force' is identity for non-promises 37 | (t (force ?)) 38 | ;; basic checks that `delay' works as expected with all kinds of values 39 | (t* (force (delay ?))) 40 | (t* (force (force (delay (delay ?))))) 41 | (t* (force (delay (force (delay ?))))) 42 | ;; basic checks that `lazy' works as expected with all kinds of values 43 | (t (force (lazy ?))) 44 | (t (force (lazy (lazy ?)))) 45 | (t (force (force (lazy (lazy ?))))) 46 | (t (force (lazy (lazy (lazy (lazy ?)))))) 47 | ;; check that `lazy' combines as expected with `delay' in regards to `force' 48 | ;; (generally, each `L*D?' sequence requires a force) 49 | (t* (force (lazy (delay ?)))) 50 | (t* (force (lazy (lazy (delay ?))))) 51 | (t* (force (lazy (lazy (lazy (delay ?)))))) 52 | ;; two delays = two forces 53 | (t* (force (force (lazy (delay (delay ?)))))) 54 | (t* (force (force (delay (lazy (delay ?)))))) 55 | (t* (force (force (lazy (lazy (delay (delay ?))))))) 56 | (t* (force (force (lazy (delay (lazy (delay ?))))))) 57 | (t* (force (force (delay (lazy (lazy (delay ?))))))) 58 | (t* (force (force (lazy (lazy (lazy (delay (delay ?)))))))) 59 | (t* (force (force (lazy (lazy (delay (lazy (delay ?)))))))) 60 | (t* (force (force (lazy (delay (lazy (lazy (delay ?)))))))) 61 | (t* (force (force (delay (lazy (lazy (lazy (delay ?)))))))) 62 | ;; now push the second force inside 63 | (t* (force (lazy (force (delay (delay ?)))))) 64 | (t* (force (delay (force (lazy (delay ?)))))) 65 | (t* (force (lazy (force (lazy (delay (delay ?))))))) 66 | (t* (force (lazy (force (delay (lazy (delay ?))))))) 67 | (t* (force (delay (force (lazy (lazy (delay ?))))))) 68 | (t* (force (lazy (force (lazy (lazy (delay (delay ?)))))))) 69 | (t* (force (lazy (force (lazy (delay (lazy (delay ?)))))))) 70 | (t* (force (lazy (force (delay (lazy (lazy (delay ?)))))))) 71 | (t* (force (delay (force (lazy (lazy (lazy (delay ?)))))))) 72 | (t* (force (lazy (delay (force (delay ?)))))) 73 | (t* (force (lazy (lazy (force (delay (delay ?))))))) 74 | (t* (force (lazy (delay (force (lazy (delay ?))))))) 75 | (t* (force (lazy (lazy (force (lazy (delay (delay ?)))))))) 76 | (t* (force (lazy (lazy (force (delay (lazy (delay ?)))))))) 77 | (t* (force (lazy (delay (force (lazy (lazy (delay ?)))))))) 78 | (t* (force (lazy (lazy (delay (force (delay ?))))))) 79 | (t* (force (lazy (lazy (lazy (force (delay (delay ?)))))))) 80 | (t* (force (lazy (lazy (delay (force (lazy (delay ?))))))))) 81 | 82 | (define (test-basic-promise-behavior) 83 | (define (force+catch p) (with-handlers ([exn? values]) (force p))) 84 | ;; results are cached 85 | (let* ([c 0] [p (delay (set! c (add1 c)) c)]) 86 | (test c => 0 87 | (force p) => 1 88 | (force p) => 1 89 | (force p) => 1 90 | c => 1)) 91 | ;; errors are caught 92 | (let ([p #f]) 93 | (test (void? (set! p (delay (error "BOOM")))) 94 | (force p) =error> "BOOM" 95 | (eq? (force+catch p) (force+catch p)))) ; and cached 96 | ;; raised values too 97 | (let ([c 0] [p #f]) 98 | (test (void? (set! p (delay (set! c (add1 c)) (raise c)))) 99 | c => 0 100 | (force p) => (raise 1) 101 | (force p) => (raise 1) 102 | c => 1)) 103 | ;; test the predicates 104 | (letrec ([forced+running? 105 | (lambda (p) (list (promise-forced? p) (promise-running? p)))] 106 | [p (delay (forced+running? p))]) 107 | (test (forced+running? p) => '(#f #f) 108 | (force p) => '(#f #t) 109 | (forced+running? p) => '(#t #f)))) 110 | 111 | (define (test-printout) 112 | (letrec ([foo (delay (set! s (format "~a" foo)) 3)] [s #f]) 113 | (test (format "~a" foo) => "#" 114 | (force foo) => 3 115 | s => "#" 116 | (format "~a" foo) => "#")) 117 | (let ([foo (delay (values 1 2 3))]) 118 | (test (format "~a" foo) => "#" 119 | (force foo) => (values 1 2 3) 120 | (format "~a" foo) => "#")) 121 | (let ([foo (delay (error "boom"))]) 122 | (test (format "~a" foo) => "#" 123 | (force foo) => (error "boom") 124 | (format "~a" foo) => "#" 125 | (format "~s" foo) => "#")) 126 | (let ([foo (delay (raise 3))]) 127 | (test (format "~a" foo) => "#" 128 | (force foo) => (raise 3) 129 | (format "~a" foo) => "#"))) 130 | 131 | (define (test-delay/name) 132 | (let* ([x 1] [p (delay/name (set! x (add1 x)) x)]) 133 | (test (promise? p) 134 | x => 1 135 | (force p) => 2 136 | x => 2 137 | (format "~a" p) => "#" 138 | (force p) => 3 139 | x => 3))) 140 | 141 | (define (test-delay/strict) 142 | (let* ([x 1] [p (delay/strict (set! x (add1 x)) x)]) 143 | (test (promise? p) 144 | x => 2 145 | (force p) => 2 146 | x => 2 147 | (force (delay/strict (values 1 2 3))) => (values 1 2 3) 148 | (promise? (force (delay/strict (delay 1))))))) 149 | 150 | (define (test-delay/sync) 151 | (letrec ([p (delay/sync (force p))]) 152 | (test (force p) =error> "reentrant")) 153 | (let* ([ch (make-channel)] 154 | [p (delay/sync (channel-get ch) (channel-get ch) 99)]) 155 | (test (format "~a" p) => "#") 156 | (thread (lambda () (force p) (channel-get ch))) 157 | (channel-put ch 'x) 158 | (test (format "~a" p) => "#") 159 | (channel-put ch 'x) 160 | (channel-put ch 'x) 161 | (test (format "~a" p) => "#" 162 | (force p) => 99))) 163 | 164 | (define (test-delay/thread) 165 | (define-syntax-rule (t delayer) 166 | (begin (let* ([ch (make-channel)] 167 | [p (delayer (channel-get ch) 99)]) 168 | (thread (lambda () (channel-put ch 'x))) 169 | (test (force p) => 99)) 170 | (test (force (delayer (+ 1 "2"))) =error> 171 | #rx"contract violation.*expected: number|not a number") 172 | (test (force (delayer (current-custodian (make-custodian)) (+ 1 "2"))) =error> 173 | #rx"contract violation.*expected: number|not a number"))) 174 | (t delay/sync) 175 | (t delay/idle) 176 | (let* ([ch (make-channel)] [p (delay/idle #:wait-for ch 99)]) 177 | (test (format "~a" p) => "#" 178 | (force p) => 99 179 | (format "~a" p) => "#")) 180 | (let* ([ch (make-channel)] 181 | [p (delay/idle #:wait-for ch (channel-get ch) 99)]) 182 | (channel-put ch 'x) 183 | (test (format "~a" p) => "#" 184 | (channel-put ch 'x) 185 | (force p) => 99 186 | (format "~a" p) => "#"))) 187 | 188 | (provide promise-tests) 189 | (module+ main (promise-tests)) 190 | (define (promise-tests) 191 | (test do (test-syntax) 192 | do (test-types) 193 | do (test-basic-promises) 194 | do (test-basic-promise-behavior) 195 | do (test-printout) 196 | do (test-delay/name) 197 | do (test-delay/strict) 198 | do (test-delay/sync) 199 | do (test-delay/thread) 200 | ;; misc tests 201 | (let ([x (lazy (delay 1))]) (force x) (force x)) => 1 202 | )) 203 | -------------------------------------------------------------------------------- /tests/space.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require tests/eli-tester) 4 | 5 | ;; tests for space safety, especially for `or' and `and' 6 | (provide space-tests) 7 | (module+ main (space-tests)) 8 | (define (space-tests) 9 | (define (one-test first-class?) 10 | (collect-garbage) 11 | (define mem (current-memory-use)) 12 | (define t 13 | (thread 14 | (lambda () 15 | (parameterize ([current-namespace (make-base-namespace)]) 16 | (eval 17 | `(module loop lazy 18 | (let () 19 | (define (list-from n) 20 | (if (= n 500000) 21 | empty 22 | (cons n (list-from (add1 n))))) 23 | ,@(if first-class? 24 | `((define (my-or x y) (or x y)) 25 | (define (my-and x y) (and x y))) 26 | '()) 27 | (define (has-negative? l) 28 | (,(if first-class? 'my-and 'and) 29 | (pair? l) 30 | (,(if first-class? 'my-or 'or) 31 | (negative? (car l)) 32 | (has-negative? (rest l))))) 33 | (! (has-negative? (list-from 0)))))) 34 | (parameterize ([current-output-port (open-output-bytes)]) 35 | (eval `(require 'loop))))))) 36 | (thread (lambda () 37 | (let loop () 38 | (sleep 0.2) 39 | (unless ((current-memory-use) . < . (* 10 mem)) 40 | (eprintf "too much memory!") 41 | (kill-thread t)) 42 | (when (thread-running? t) 43 | (loop))))) 44 | (sync t) 45 | (void)) 46 | (one-test #f) 47 | (one-test #t)) 48 | --------------------------------------------------------------------------------