Created
April 10, 2025 09:07
-
-
Save panicz/1dbc06347dba3700d6790c8c0fbfb26b to your computer and use it in GitHub Desktop.
Tagbidy in Scheme
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| ;; a Scheme macro showing how Common Lisp' | |
| ;; tagbody could be translated to Scheme | |
| ;; (Personally I wouldn't recommend using | |
| ;; that macro) | |
| ;; It's been developed under Guile, but should | |
| ;; be portable to any implementation that | |
| ;; supports syntax-case. | |
| (import (system base compile)) | |
| (import (ice-9 pretty-print)) | |
| (define* (expand-form e #:key (opts '())) | |
| (let ((expanded (decompile | |
| (compile e #:from 'scheme | |
| #:to 'tree-il | |
| #:env (current-module)) | |
| #:from 'tree-il | |
| #:to 'scheme | |
| #:opts opts))) | |
| (pretty-print expanded) | |
| expanded)) | |
| (define-syntax-rule (expand expression) | |
| (expand-form 'expression)) | |
| (define-syntax e.g. | |
| (syntax-rules (===>) | |
| ((e.g. expression ===> value) | |
| (let ((result expression)) | |
| (unless (equal? result 'value) | |
| (error "expected "'value", got "result)) | |
| result)))) | |
| (define-syntax-rule (define-label name go . commands) | |
| (define (name) | |
| (call/cc | |
| (lambda (return) | |
| (define (go label) (return (label))) | |
| . commands)))) | |
| (define-syntax tagbody-compile | |
| (syntax-rules () | |
| ((tagbody-compile (define-label name go actions ...) | |
| (command . *) . commands) | |
| (tagbody-compile (define-label name go actions | |
| ... (command . *)) . commands)) | |
| ((tagbody-compile (define-label name go actions | |
| ...) label . commands) | |
| (begin | |
| (define-label name go actions ... (label)) | |
| (tagbody-compile (define-label label go) . commands))) | |
| ((tagbody-compile definition) | |
| definition))) | |
| (define-syntax-rule (tagbody/go go . commands) | |
| (begin | |
| (tagbody-compile (define-label start go) . commands) | |
| (start))) | |
| (define-macro (tagbody . commands) | |
| `(tagbody/go go . ,commands)) | |
| (define-syntax-rule (incf var value) | |
| (set! var (+ var value))) | |
| (define-syntax-rule (setq var value) | |
| (set! var value)) | |
| (e.g. | |
| ;; http://clhs.lisp.se/Body/s_tagbod.htm | |
| (let ((val 0)) | |
| (tagbody | |
| (setq val 1) | |
| (go point-a) | |
| (incf val 16) | |
| point-c | |
| (incf val 04) | |
| (go point-b) | |
| (incf val 32) | |
| point-a | |
| (incf val 02) | |
| (go point-c) | |
| (incf val 64) | |
| point-b | |
| (incf val 08)) | |
| val) ===> 15) | |
| (e.g. | |
| (expand | |
| (let ((val 0)) | |
| (tagbody | |
| (setq val 1) | |
| (go point-a) | |
| (incf val 16) | |
| point-c | |
| (incf val 04) | |
| (go point-b) | |
| (incf val 32) | |
| point-a | |
| (incf val 02) | |
| (go point-c) | |
| (incf val 64) | |
| point-b | |
| (incf val 08)) | |
| val)) ===> | |
| (let ((val 0)) | |
| (define (start) | |
| (call/cc | |
| (lambda (return) | |
| (define (go label) (return (label))) | |
| (set! val 1) | |
| (go point-a) | |
| (set! val (+ val 16)) | |
| (point-c)))) | |
| (define (point-c) | |
| (call/cc | |
| (lambda (return) | |
| (define (go label) (return (label))) | |
| (set! val (+ val 4)) | |
| (go point-b) | |
| (set! val (+ val 32)) | |
| (point-a)))) | |
| (define (point-a) | |
| (call/cc | |
| (lambda (return) | |
| (define (go label) (return (label))) | |
| (set! val (+ val 2)) | |
| (go point-c) | |
| (set! val (+ val 64)) | |
| (point-b)))) | |
| (define (point-b) | |
| (call/cc | |
| (lambda (return) | |
| (define (go label) (return (label))) | |
| (set! val (+ val 8))))) | |
| (start) | |
| val)) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment