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

new library

Browse source
This commit is contained in:
Justin Ethier 2016-02-13 22:36:49 -05:00
parent af13509e0a
commit faecc90ba2
3 changed files with 51 additions and 21 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
Makefile
View file

@ -11,6 +11,7 @@ BOOTSTRAP_DIR = ../cyclone-bootstrap
SMODULES = \ SMODULES = \
scheme/base \ scheme/base \
scheme/case-lambda \
scheme/char \ scheme/char \
scheme/cxr \ scheme/cxr \
scheme/eval \ scheme/eval \
@ -81,6 +82,7 @@ bootstrap: icyc
cp gc.c $(BOOTSTRAP_DIR) cp gc.c $(BOOTSTRAP_DIR)
cp dispatch.c $(BOOTSTRAP_DIR) cp dispatch.c $(BOOTSTRAP_DIR)
cp scheme/base.c $(BOOTSTRAP_DIR)/scheme cp scheme/base.c $(BOOTSTRAP_DIR)/scheme
cp scheme/case-lambda.c $(BOOTSTRAP_DIR)/scheme
cp scheme/cxr.c $(BOOTSTRAP_DIR)/scheme cp scheme/cxr.c $(BOOTSTRAP_DIR)/scheme
cp scheme/read.c $(BOOTSTRAP_DIR)/scheme cp scheme/read.c $(BOOTSTRAP_DIR)/scheme
cp scheme/write.c $(BOOTSTRAP_DIR)/scheme cp scheme/write.c $(BOOTSTRAP_DIR)/scheme

42
macro-testing.scm
View file

@ -45,27 +45,27 @@
; (if test ; (if test
; (begin result1 result2 ...) ; (begin result1 result2 ...)
; (guard-aux reraise clause1 clause2 ...))))) ; (guard-aux reraise clause1 clause2 ...)))))
;
(define-syntax %case ; (define-syntax %case
(syntax-rules () ; (syntax-rules ()
((%case args len n p ((params ...) . body) . rest) ; ((%case args len n p ((params ...) . body) . rest)
(if (= len (length '(params ...))) ; (if (= len (length '(params ...)))
(apply (lambda (params ...) . body) args) ; (apply (lambda (params ...) . body) args)
(%case args len 0 () . rest))) ; (%case args len 0 () . rest)))
((%case args len n (p ...) ((x . y) . body) . rest) ; ((%case args len n (p ...) ((x . y) . body) . rest)
(%case args len (+ n 1) (p ... x) (y . body) . rest)) ; (%case args len (+ n 1) (p ... x) (y . body) . rest))
((%case args len n (p ...) (y . body) . rest) ; ((%case args len n (p ...) (y . body) . rest)
(if (>= len n) ; (if (>= len n)
(apply (lambda (p ... . y) . body) args) ; (apply (lambda (p ... . y) . body) args)
(%case args len 0 () . rest))) ; (%case args len 0 () . rest)))
((%case args len n p) ; ((%case args len n p)
(error "case-lambda: no cases matched")))) ; (error "case-lambda: no cases matched"))))
(define-syntax case-lambda ; (define-syntax case-lambda
(syntax-rules () ; (syntax-rules ()
((case-lambda . clauses) ; ((case-lambda . clauses)
(lambda args (let ((len (length args))) (%case args len 0 () . clauses)))))) ; (lambda args (let ((len (length args))) (%case args len 0 () . clauses))))))
;(lambda args (let ((len (length* args))) (%case args len 0 () . clauses)))))) ; ;(lambda args (let ((len (length* args))) (%case args len 0 () . clauses))))))
;
;(define-syntax define-values ;(define-syntax define-values
; (syntax-rules () ; (syntax-rules ()
; ((define-values () expr) ; ((define-values () expr)

28
scheme/case-lambda.sld Normal file
View file

@ -0,0 +1,28 @@
(define-library (scheme case-lambda)
(import (scheme base))
(export
case-lambda
)
(begin
(define-syntax %case
(syntax-rules ()
((%case args len n p ((params ...) . body) . rest)
(if (= len (length '(params ...)))
(apply (lambda (params ...) . body) args)
(%case args len 0 () . rest)))
((%case args len n (p ...) ((x . y) . body) . rest)
(%case args len (+ n 1) (p ... x) (y . body) . rest))
((%case args len n (p ...) (y . body) . rest)
(if (>= len n)
(apply (lambda (p ... . y) . body) args)
(%case args len 0 () . rest)))
((%case args len n p)
(error "case-lambda: no cases matched"))))
(define-syntax case-lambda
(syntax-rules ()
((case-lambda . clauses)
(lambda args (let ((len (length args))) (%case args len 0 () . clauses))))))
;(lambda args (let ((len (length* args))) (%case args len 0 () . clauses))))))
))