Jinser/psyntax

demo/define-syntax-def.scm

@@ -0,0 +1,3 @@
+(define-library (demo define-syntax-def)
+  (export answer)
+  (begin (define answer 42)))

demo/define-syntax-last.scm

@@ -0,0 +1,5 @@
+(define-library (demo define-syntax-last)
+  (import (demo define-syntax-next))
+  (begin
+    (display (ans))
+    (newline)))

demo/define-syntax-next.scm

@@ -0,0 +1,6 @@
+(define-library (demo define-syntax-next)
+  (import (demo define-syntax-def))
+  (export ans)
+  (begin
+    (define (ans) (+ 1 answer))
+    (newline)))

demo/demo_psyntax.scm

@@ -0,0 +1,5 @@
+(define-library (demo demo_psyntax)
+  (import (scheme base))
+  (begin
+    (display (max 10 11))))
+

demo/x.scm

@@ -0,0 +1,58 @@
+(module scheme.base (let-values)
+  (define-syntax let-values
+    (lambda (x)
+      (syntax-case x ()
+        ((_ ((binds exp)) b0 b1 ...)
+         (syntax (call-with-values (lambda () exp)
+                   (lambda binds b0 b1 ...))))
+        ((_ (clause ...) b0 b1 ...)
+         (let lp ((clauses (syntax (clause ...)))
+                  (ids '())
+                  (tmps '()))
+           (if (null? clauses)
+               (with-syntax (((id ...) ids)
+                             ((tmp ...) tmps))
+                 (syntax (let ((id tmp) ...)
+                           b0 b1 ...)))
+               (syntax-case (car clauses) ()
+                 (((var ...) exp)
+                  (with-syntax (((new-tmp ...) (generate-temporaries 
+                                                (syntax (var ...))))
+                                ((id ...) ids)
+                                ((tmp ...) tmps))
+                    (with-syntax ((inner (lp (cdr clauses)
+                                             (syntax (var ... id ...))
+                                             (syntax (new-tmp ... tmp ...)))))
+                      (syntax (call-with-values (lambda () exp)
+                                (lambda (new-tmp ...) inner))))))
+                 ((vars exp)
+                  (with-syntax ((((new-var . new-tmp) ...)
+                                 (let lp ((vars (syntax vars)))
+                                   (syntax-case vars ()
+                                     ((id . rest)
+                                      (acons (syntax id)
+                                             (car
+                                              (generate-temporaries (syntax (id))))
+                                             (lp (syntax rest))))
+                                     (id (acons (syntax id)
+                                                (car
+                                                 (generate-temporaries (syntax (id))))
+                                                '())))))
+                                ((id ...) ids)
+                                ((tmp ...) tmps))
+                    (with-syntax ((inner (lp (cdr clauses)
+                                             (syntax (new-var ... id ...))
+                                             (syntax (new-tmp ... tmp ...))))
+                                  (args (let lp ((tmps (syntax (new-tmp ...))))
+                                          (syntax-case tmps ()
+                                            ((id) (syntax id))
+                                            ((id . rest) (cons (syntax id)
+                                                               (lp (syntax rest))))))))
+                      (syntax (call-with-values (lambda () exp)
+                                (lambda args inner))))))))))))))
+
+(module demo ()
+  (import scheme.base)
+  (let-values (((a b) (values 1 2)))
+    (display b)
+    (newline)))

goldfish/liii/alist.scm

@@ -3,26 +3,31 @@
 ;
 
 (define-library (liii alist)
-  (import (liii base) (liii list) (liii error) (scheme case-lambda))
+  (import (liii base) (liii list) (liii error))
   (export alist? alist-cons alist-ref alist-ref/default vector->alist)
   (begin
 
     (define (alist? l)
       (and (list? l) (every pair? l)))
 
     (define alist-ref
-      (case-lambda ((alist key) (alist-ref alist key
-                                           (lambda ()
-                                             (key-error "alist-ref: key not found " key))))
-                   ((alist key thunk) (alist-ref alist key thunk eqv?))
-                   ((alist key thunk =) (let ((value (assoc key alist =)))
-                       (if value (cdr value) (thunk))))))
+      (lambda (alist key . rest)
+        (let ((thunk (if (null? rest)
+                         (lambda () (error 'alist-ref "key not found: ~s" key))
+                         (car rest)))
+              (= (cond ((null? rest) eqv?)
+                       ((null? (cdr rest)) eqv?)
+                       (else (cadr rest)))))
+          (let ((value (assoc key alist =)))
+            (if value (cdr value) (thunk))))))
 
     (define alist-ref/default
-      (case-lambda ((alist key default)
-                    (alist-ref alist key (lambda () default)))
-                   ((alist key default =)
-                    (alist-ref alist key (lambda () default) =))))
+      (lambda (alist key . rest)
+        (if (null? rest)
+            (error 'alist-ref/default "missing default argument")
+            (let ((default (car rest))
+                  (= (if (null? (cdr rest)) eqv? (cadr rest))))
+              (alist-ref alist key (lambda () default) =)))))
 
     ; MIT License
     ; Copyright guenchi (c) 2018 - 2019

goldfish/liii/base.scm

@@ -40,7 +40,9 @@
     ; R7RS 6.7: String
     string-copy
     ; R7RS 6.8 Vector
-    vector->string string->vector vector-copy vector-copy! vector-fill! vector-append
+    vector->string string->vector vector-copy vector-copy! vector-fill!
+    ; workaround for binding s7 primitives
+    (rename vector-append vector-append)
     ; R7RS 6.9 Bytevectors
     bytevector? make-bytevector bytevector bytevector-length bytevector-u8-ref
     bytevector-u8-set! bytevector-copy bytevector-append
@@ -90,25 +92,34 @@
       `(let ((,name1 ,value1))
          ,@body))
 
-    ; 0 clause BSD, from S7 repo stuff.scm
-    (define-macro (typed-lambda args . body)
-      ; (typed-lambda ((var [type])...) ...)
-      (if (symbol? args)
-          (apply lambda args body)
-          (let ((new-args (copy args)))
-            (do ((p new-args (cdr p)))
-                ((not (pair? p)))
-                (if (pair? (car p))
-                    (set-car! p (caar p))))
-            `(lambda ,new-args
-               ,@(map (lambda (arg)
-                        (if (pair? arg)
-                            `(unless (,(cadr arg) ,(car arg))
+    (define-syntax typed-lambda
+      (lambda (stx)
+        (define (split-args args)
+          ;; args 是语法列表，形如 ((var type) ...) 或 (var ...)
+          (let loop ((args args) (clean '()) (checks '()))
+            (syntax-case args ()
+              (() (values (reverse clean) (reverse checks)))
+              (((var type) . rest)
+               (loop (syntax rest)
+                     (cons (syntax var) clean)
+                     (cons #`(unless (type var)
                                (error 'type-error
-                                 "~S is not ~S~%" ',(car arg) ',(cadr arg)))
-                            (values)))
-                      args)
-               ,@body))))
+                                 "~S is not ~S" 'var 'type))
+                           checks)))
+              ((var . rest)
+               (if (identifier? (syntax var))
+                   (loop (syntax rest) (cons (syntax var) clean) checks)
+                   (syntax-error args "Invalid argument specification"))))))
+        (syntax-case stx ()
+          ((_ args body1 body2 ...)
+           (call-with-values (lambda () (split-args (syntax args)))
+             (lambda (clean-args checks)
+               (with-syntax (((clean ...) clean-args)
+                             ((check ...) checks)
+                             ((body ...) #'(body1 body2 ...)))
+                 #'(lambda (clean ...)
+                     check ...
+                     body ...))))))))
 
     ) ; end of begin
   ) ; end of define-library