mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-18 21:29:19 +02:00
31 lines
1.3 KiB
Scheme
31 lines
1.3 KiB
Scheme
|
|
(define-library (srfi 229)
|
|
(import (scheme base) (scheme case-lambda) (chibi ast) (only (chibi) opcode?))
|
|
(export case-lambda/tag lambda/tag procedure/tag? procedure-tag)
|
|
(begin
|
|
(define procedure-tag-object (list 'procedure-tag))
|
|
(define (procedure->tagged f tag)
|
|
(make-procedure (procedure-flags f)
|
|
(procedure-arity f)
|
|
(procedure-code f)
|
|
(vector-append (or (procedure-vars f) '#())
|
|
(vector tag procedure-tag-object))))
|
|
(define-syntax lambda/tag
|
|
(syntax-rules ()
|
|
((lambda/tag tag-expr formals . body)
|
|
(procedure->tagged (lambda formals . body) tag-expr))))
|
|
(define-syntax case-lambda/tag
|
|
(syntax-rules ()
|
|
((case-lambda/tag tag-expr . clauses)
|
|
(procedure->tagged (case-lambda . clauses) tag-expr))))
|
|
(define (procedure/tag? f)
|
|
(and (procedure? f)
|
|
(not (opcode? f))
|
|
(let ((vars (procedure-vars f)))
|
|
(and (vector? vars)
|
|
(> (vector-length vars) 1)
|
|
(eq? procedure-tag-object
|
|
(vector-ref vars (- (vector-length vars) 1)))))))
|
|
(define (procedure-tag f)
|
|
(let ((vars (procedure-vars f)))
|
|
(vector-ref vars (- (vector-length vars) 2))))))
|