spook

A "game" for the 2023 Autumn Lisp Game Jam. Won first place! (from the bottom...)
git clone https://kaka.farm/~git/spook
Log | Files | Refs | LICENSE

syntax.scm (2708B)

      1 ;;;; syntax.scm - various useful macros
      2 
      3 
      4 (define-syntax define-syntax-rule
      5   (syntax-rules ___ ()
      6     ((_ (name args ___) rule)
      7      (define-syntax name
      8        (syntax-rules ()
      9 	 ((_ args ___) rule))))))
     10 
     11 (define-syntax-rule (when x y z ...)
     12   (if x (begin y z ...)))
     13 
     14 (define-syntax-rule (unless x y z ...)
     15   (if (not x) (begin y z ...)))
     16 
     17 (define-syntax cut
     18   (syntax-rules (<> <...>)
     19     ;; construct fixed- or variable-arity procedure:
     20     ((_ "1" (slot-name ...) (proc arg ...))
     21      (lambda (slot-name ...) (proc arg ...)))
     22     ((_ "1" (slot-name ...) (proc arg ...) <...>)
     23      (lambda (slot-name ... . rest-slot) (apply proc arg ... rest-slot)))
     24     ;; process one slot-or-expr
     25     ((_ "1" (slot-name ...)   (position ...)      <>  . se)
     26      (cut "1" (slot-name ... x) (position ... x)        . se))
     27     ((_ "1" (slot-name ...)   (position ...)      nse . se)
     28      (cut "1" (slot-name ...)   (position ... nse)      . se))
     29     ((_ . slots-or-exprs)
     30      (cut "1" () () . slots-or-exprs))) )
     31 
     32 (define-syntax fluid-let
     33   (syntax-rules ()
     34     ((_ ((v1 e1) ...) b1 b2 ...)
     35      (fluid-let "temps" () ((v1 e1) ...) b1 b2 ...))
     36     ((_ "temps" (t ...) ((v1 e1) x ...) b1 b2 ...)
     37      (let ((temp e1))
     38        (fluid-let "temps" ((temp e1 v1) t ...) (x ...) b1 b2 ...)))
     39     ((_ "temps" ((t e v) ...) () b1 b2 ...)
     40      (let-syntax ((swap!
     41                    (syntax-rules ()
     42                      ((swap! a b)
     43                       (let ((tmp a))
     44                         (set! a b)
     45                         (set! b tmp))))))
     46        (dynamic-wind
     47         (lambda ()
     48           (swap! t v) ...)
     49         (lambda ()
     50           b1 b2 ...)
     51         (lambda ()
     52           (swap! t v) ...))))))
     53 
     54 (define-syntax-rule (begin1 x1 x2 ...)
     55   (%call-with-saved-values
     56    (lambda () x1)
     57    (lambda () (begin x2 ...))))
     58 
     59 (define-syntax-rule (syntax-error msg arg ...)
     60   (%syntax-error msg arg ...))
     61 
     62 (define-syntax-rule (new class arg ...)
     63   (%new class arg ...))
     64 
     65 (define-syntax define-entry-point
     66   (syntax-rules ()
     67     ((_ (name . llist) body ...) 
     68      (define-entry-point name (lambda llist body ...)))
     69     ((_ name x)
     70      (begin
     71        (define name x)
     72        (define (%host-set! 'name (callback name)))))))
     73 
     74 (define-syntax-rule (define-native name ...)
     75   (begin
     76     (define-syntax name
     77       (native (%host-ref 'name)))
     78     ...))
     79 
     80 (define-syntax-rule (define-native-method name ...)
     81   (begin
     82     (define-syntax name
     83       (native-method (%host-ref 'name)))
     84     ...))
     85 
     86 (define-syntax set!
     87   (let-syntax ((primitive-set! set!))
     88     (syntax-rules ()
     89       ((_ (prop x) y)
     90        (%property-set! 'prop x y))
     91       ((_ var x) 
     92        (primitive-set! var x)))))
     93 
     94 (define-syntax-rule (optional x y)
     95   (if (pair? x) (car x) y))