diff --git a/demo/define-syntax-def.scm b/demo/define-syntax-def.scm new file mode 100644 index 00000000..a6e93530 --- /dev/null +++ b/demo/define-syntax-def.scm @@ -0,0 +1,3 @@ +(define-library (demo define-syntax-def) + (export answer) + (begin (define answer 42))) diff --git a/demo/define-syntax-last.scm b/demo/define-syntax-last.scm new file mode 100644 index 00000000..5f9cff52 --- /dev/null +++ b/demo/define-syntax-last.scm @@ -0,0 +1,5 @@ +(define-library (demo define-syntax-last) + (import (demo define-syntax-next)) + (begin + (display (ans)) + (newline))) diff --git a/demo/define-syntax-next.scm b/demo/define-syntax-next.scm new file mode 100644 index 00000000..0c51ca73 --- /dev/null +++ b/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))) diff --git a/demo/demo_psyntax.scm b/demo/demo_psyntax.scm new file mode 100644 index 00000000..51a843ee --- /dev/null +++ b/demo/demo_psyntax.scm @@ -0,0 +1,5 @@ +(define-library (demo demo_psyntax) + (import (scheme base)) + (begin + (display (max 10 11)))) + diff --git a/demo/x.scm b/demo/x.scm new file mode 100644 index 00000000..b328a8b7 --- /dev/null +++ b/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))) diff --git a/goldfish/liii/alist.scm b/goldfish/liii/alist.scm index 7fbd4e4c..11d08578 100644 --- a/goldfish/liii/alist.scm +++ b/goldfish/liii/alist.scm @@ -3,7 +3,7 @@ ; (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 @@ -11,18 +11,23 @@ (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 diff --git a/goldfish/liii/base.scm b/goldfish/liii/base.scm index d0144848..a1b0ca64 100644 --- a/goldfish/liii/base.scm +++ b/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 diff --git a/goldfish/liii/case.scm b/goldfish/liii/case.scm deleted file mode 100644 index 1ac938ed..00000000 --- a/goldfish/liii/case.scm +++ /dev/null @@ -1,344 +0,0 @@ -; -; Copyright (C) 2024 The Goldfish Scheme Authors -; -; Licensed under the Apache License, Version 2.0 (the "License"); -; you may not use this file except in compliance with the License. -; You may obtain a copy of the License at -; -; http://www.apache.org/licenses/LICENSE-2.0 -; -; Unless required by applicable law or agreed to in writing, software -; distributed under the License is distributed on an "AS IS" BASIS, WITHOUT -; WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the -; License for the specific language governing permissions and limitations -; under the License. -; - -(define-library (liii case) - (import (liii base)) - (export case*) - (begin - - ; 0 clause BSD, from S7 repo case.scm - (define case* - (let ((case*-labels (lambda (label) - (let ((labels ((funclet ((funclet 'case*) 'case*-helper)) 'labels))) - (labels (symbol->string label))))) ; if ellipsis, this has been quoted by case* - - (case*-match? (lambda* (matchee pattern (e (curlet))) - (let ((matcher ((funclet ((funclet 'case*) 'case*-helper)) 'handle-sequence))) - (or (equivalent? matchee pattern) - (and (or (pair? matchee) - (vector? matchee)) - (begin - (fill! ((funclet ((funclet 'case*) 'case*-helper)) 'labels) #f) ; clear labels - ((matcher pattern e) matchee))))))) - (case*-helper - (with-let (unlet) - (define labels (make-hash-table)) - - (define (ellipsis? pat) - (and (undefined? pat) - (or (equal? pat #<...>) - (let ((str (object->string pat))) - (and (char-position #\: str) - (string=? "...>" (substring str (- (length str) 4)))))))) - - (define (ellipsis-pair-position pos pat) - (and (pair? pat) - (if (ellipsis? (car pat)) - pos - (ellipsis-pair-position (+ pos 1) (cdr pat))))) - - (define (ellipsis-vector-position pat vlen) - (let loop ((pos 0)) - (and (< pos vlen) - (if (ellipsis? (pat pos)) - pos - (loop (+ pos 1)))))) - - (define (splice-out-ellipsis sel pat pos e) - (let ((sel-len (length sel)) - (new-pat-len (- (length pat) 1)) - (ellipsis-label (and (not (eq? (pat pos) #<...>)) - (let* ((str (object->string (pat pos))) - (colon (char-position #\: str))) - (and colon - (substring str 2 colon)))))) - (let ((func (and (string? ellipsis-label) - (let ((comma (char-position #\, ellipsis-label))) - (and comma - (let ((str (substring ellipsis-label (+ comma 1)))) - (set! ellipsis-label (substring ellipsis-label 0 comma)) - (let ((func-val (symbol->value (string->symbol str) e))) - (if (undefined? func-val) - (error 'unbound-variable "function ~S is undefined\n" func)) - (if (not (procedure? func-val)) - (error 'wrong-type-arg "~S is not a function\n" func)) - func-val))))))) - (if (pair? pat) - (cond ((= pos 0) ; ellipsis at start of pattern - (if ellipsis-label - (set! (labels ellipsis-label) - (list 'quote (copy sel (make-list (- sel-len new-pat-len)))))) - (values (list-tail sel (- sel-len new-pat-len)) - (cdr pat) - (or (not func) - (func (cadr (labels ellipsis-label)))))) ; value is (quote ...) and we want the original list here - - ((= pos new-pat-len) ; ellipsis at end of pattern - (if ellipsis-label - (set! (labels ellipsis-label) - (list 'quote (copy sel (make-list (- sel-len pos)) pos)))) - (values (copy sel (make-list pos)) - (copy pat (make-list pos)) - (or (not func) - (func (cadr (labels ellipsis-label)))))) - - (else ; ellipsis somewhere in the middle - (let ((new-pat (make-list new-pat-len)) - (new-sel (make-list new-pat-len))) - (if ellipsis-label - (set! (labels ellipsis-label) - (list 'quote (copy sel (make-list (- sel-len new-pat-len)) pos)))) - (copy pat new-pat 0 pos) - (copy pat (list-tail new-pat pos) (+ pos 1)) - (copy sel new-sel 0 pos) - (copy sel (list-tail new-sel pos) (- sel-len pos)) - (values new-sel new-pat - (or (not func) - (func (cadr (labels ellipsis-label)))))))) - - (cond ((= pos 0) - (if ellipsis-label - (set! (labels ellipsis-label) - (list 'quote (copy sel (make-list (- sel-len new-pat-len)))))) - (values (subvector sel (max 0 (- sel-len new-pat-len)) sel-len) ; was new-pat-len (max 0 (- sel-len new-pat-len)) - (subvector pat 1 (+ new-pat-len 1)) ; new-pat-len 1 - (or (not func) - (func (cadr (labels ellipsis-label)))))) - - ((= pos new-pat-len) - (if ellipsis-label - (set! (labels ellipsis-label) - (list 'quote (copy sel (make-list (- sel-len new-pat-len)) pos)))) - (values (subvector sel 0 new-pat-len) - (subvector pat 0 new-pat-len) - (or (not func) - (func (cadr (labels ellipsis-label)))))) - - (else - (let ((new-pat (make-vector new-pat-len)) - (new-sel (make-vector new-pat-len))) - (if ellipsis-label - (set! (labels ellipsis-label) - (list 'quote (copy sel (make-list (- sel-len new-pat-len)) pos)))) - (copy pat new-pat 0 pos) - (copy pat (subvector new-pat pos new-pat-len) (+ pos 1)) ; (- new-pat-len pos) pos) copy: (+ pos 1)) - (copy sel new-sel 0 pos) - (copy sel (subvector new-sel pos new-pat-len) (- sel-len pos)) - ; (- new-pat-len pos) pos) copy: (- sel-len pos)) - (values new-sel new-pat - (or (not func) - (cadr (func (labels ellipsis-label)))))))))))) - - (define (handle-regex x) #f) - ;(define handle-regex - ; (let ((rg ((*libc* 'regex.make))) ; is this safe? - ; (local-regcomp (*libc* 'regcomp)) - ; (local-regerror (*libc* 'regerror)) - ; (local-regexec (*libc* 'regexec)) - ; (local-regfree (*libc* 'regfree))) - ; (lambda (reg) - ;(lambda (x) - ; (and (string? x) - ; (let ((res (local-regcomp rg (substring reg 1 (- (length reg) 1)) 0))) - ; (unless (zero? res) - ; (error 'regex-error "~S~%" (local-regerror res rg))) - ; (set! res (local-regexec rg x 0 0)) - ; (local-regfree rg) - ; (zero? res))))))) - - (define (undefined->function undef e) ; handle the pattern descriptor ("undef") of the form #< whatever >, "e" = caller's curlet - (let* ((str1 (object->string undef)) - (str1-end (- (length str1) 1))) - (if (not (char=? (str1 str1-end) #\>)) - (error 'wrong-type-arg "pattern descriptor does not end in '>': ~S\n" str1)) - (let ((str (substring str1 2 str1-end))) - (if (= (length str) 0) ; #<> = accept anything - (lambda (x) #t) - (let ((colon (char-position #\: str))) - (cond (colon ; # might be # or # - (let ((label (substring str 0 colon)) ; str is label:... - (func (substring str (+ colon 1)))) ; func might be "" - (cond ((labels label) ; see if we already have saved something under this label - (lambda (sel) ; if so, return function that will return an error - (error 'syntax-error "label ~S is defined twice: old: ~S, new: ~S~%" label (labels label) sel))) - - ;; otherwise the returned function needs to store the current sel-item under label in labels - ((zero? (length func)) - (lambda (x) - (set! (labels label) x) ; #, set label, accept anything - #t)) - - ((char=? (func 0) #\") ; labelled regex, # - (lambda (x) - (set! (labels label) x) - (handle-regex func))) - - (else ; # - (let ((func-val (symbol->value (string->symbol func) e))) - (if (undefined? func-val) - (error 'unbound-variable "function ~S is undefined\n" func) - (if (not (procedure? func-val)) - (error 'wrong-type-arg "~S is not a function\n" func) - (lambda (x) ; set label and call func - (set! (labels label) x) - (func-val x))))))))) - - ;; if no colon either #