49 lines
2.0 KiB
Racket
49 lines
2.0 KiB
Racket
#lang racket/base
|
|
(require 2htdp/image
|
|
racket/runtime-path
|
|
(for-syntax "private/planetcute-image-list.rkt")
|
|
(for-syntax racket/base))
|
|
|
|
(define-syntax (definitions stx)
|
|
#`(begin
|
|
#,@(for/list ([img (in-list (apply append (map cdr images)))])
|
|
#`(begin
|
|
(provide #,img)
|
|
(define-syntax #,img (make-planetcute-transformer '#,img))))))
|
|
|
|
|
|
(define-for-syntax (make-planetcute-transformer img)
|
|
(make-set!-transformer
|
|
(let ([saved-id-table (make-hasheq)])
|
|
(λ (stx)
|
|
(if (eq? 'expression (syntax-local-context))
|
|
;; In an expression context:
|
|
(let* ([key (syntax-local-lift-context)]
|
|
;; Already lifted in this lifting context?
|
|
[lifted-id
|
|
(or (hash-ref saved-id-table key #f)
|
|
;; No: lift the require for the image:
|
|
(syntax-local-lift-require `(lib ,(format "~a.rkt" img) "2htdp" "planetcute")
|
|
(datum->syntax stx img)))])
|
|
(when key (hash-set! saved-id-table key lifted-id))
|
|
;; Expand to a use of the lifted expression:
|
|
(with-syntax ([saved-id (syntax-local-introduce lifted-id)])
|
|
(syntax-case stx (set!)
|
|
[name (identifier? #'name) #'saved-id]
|
|
[(set! id arg)
|
|
(raise-syntax-error
|
|
'2htdp/planetcute
|
|
"cannot set! a Planet Cute variable"
|
|
stx #'id)]
|
|
[(name . more)
|
|
(raise-syntax-error
|
|
'2htdp/planetcute
|
|
"the Planet Cute variables cannot be used after an open parenthesis as they are not functions"
|
|
stx #'id)])))
|
|
;; In case of partial expansion for module-level and internal-defn
|
|
;; contexts, delay expansion until it's a good time to lift
|
|
;; expressions:
|
|
(quasisyntax/loc stx (#%expression #,stx)))))))
|
|
|
|
(definitions)
|