Navigation Menu

Skip to content

Instantly share code, notes, and snippets.

@SaitoAtsushi
Created January 16, 2011 08:41
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save SaitoAtsushi/781655 to your computer and use it in GitHub Desktop.
Save SaitoAtsushi/781655 to your computer and use it in GitHub Desktop.
answer M-99 written in Scheme
;; http://common-lisp-users.jp/index.cgi?M-99
(define-syntax inc1
(syntax-rules ()
((_ v)
(set! v (+ v 1)))))
(define-syntax when
(syntax-rules ()
((_ p b0 b1 ...)
(if p (begin b0 b1 ...)))))
(define-syntax unless
(syntax-rules ()
((_ p b0 b1 ...)
(when (not p) b0 b1 ...))))
(define-syntax while
(syntax-rules ()
((_ p b0 b1 ...)
(let loop () (when p (begin b0 b1 ... (loop)))))))
(define-syntax until
(syntax-rules ()
((_ p b0 b1 ...)
(while (not p) b0 b1 ...))))
(define-syntax do-forever
(lambda(stx)
(syntax-case stx ()
((k b0 b1 ...)
(with-syntax ((return (datum->syntax #'k 'return)))
#'(call/cc (lambda(return) (while #t b0 b1 ...))))))))
(define-syntax inc
(syntax-rules ()
((_ v n)
(set! v (+ v n)))))
((_ v)
(inc1 v))
(define-syntax my-and
(syntax-rules ()
((_ x) x)
((_ x r ...)
(if x (my-and r ...) #f))))
(define-syntax my-or
(syntax-rules ()
((_ x) x)
((_ x r ...)
(let ((t x))
(if t t (my-or r ...))))))
(define-syntax my-let
(syntax-rules ()
((_ ((v e) ...) b0 b1 ...)
((lambda(v ...) b0 b1 ...) e ...))))
(define-syntax my-let*
(syntax-rules ()
((_ ((v e)) body ...)
((lambda(v) body ...) e))
((_ ((v e) r ...) b0 b1 ...)
((lambda(v) (my-let* (r ...) b0 b1 ...)) e))))
(define-syntax my-cond
(syntax-rules ()
((_ (p e ...))
(if p (begin e ...)))
((_ (p e ...) r ...)
(if p (begin e ...) (my-cond r ...)))))
(define-syntax psetq
(syntax-rules ()
((_ r ...)
(letrec-syntax ((%%psetq
(syntax-rules ()
((_ (v f n) (... ...))
(let ((n f) (... ...)) (set! v n) (... ...)))))
(%psetq
(syntax-rules ()
((_ (a (... ...)))
(%%psetq a (... ...)))
((_ (a (... ...)) v f e (... ...))
(%psetq (a (... ...) (v f n)) e (... ...))))))
(%psetq () r ...)))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment