Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-19 05:39:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

implement (srfi 229)

Browse source
This commit is contained in:
Alex Shinn 2021-12-02 22:03:58 +09:00
parent 71cc9b0d3c
commit 0da288d053
2 changed files with 51 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

29
lib/srfi/229.sld Normal file
View file

@ -0,0 +1,29 @@
(define-library (srfi 229)
(import (scheme base) (scheme case-lambda) (chibi ast))
(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)
(let ((vars (procedure-vars f)))
(and (vector? vars)
(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))))))

22
lib/srfi/229/test.sld Normal file
View file

@ -0,0 +1,22 @@
(define-library (srfi 229 test)
(import (scheme base) (srfi 229) (chibi test))
(export run-tests)
(begin
(define (run-tests . o)
(test-begin "(srfi 229)")
(let ()
(define f
(lambda/tag 42
(x)
(* x x)))
(define f*
(lambda/tag 43
(x)
(* x x)))
(test-assert (procedure/tag? f))
(test 9 (f 3))
(test 42 (procedure-tag f))
(test-not (eqv? f f*))
(test 43 (procedure-tag f*)))
(test-end))))