conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Fixed some of bug 186155: Incorrect syntax errors for define

This commit is contained in:
Abdulaziz Ghuloum 2008-01-27 19:12:20 -05:00
parent 7f971d710a
commit a43177d399
2 changed files with 38 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
scheme/ikarus.bytevectors.ss
View File

@ -73,7 +73,7 @@
(ikarus system $pairs) (ikarus system $pairs)
(ikarus system $bytevectors)) (ikarus system $bytevectors))
(define (native-endianness) 'big) ;;; HARDCODED (define (native-endianness) 'little) ;;; HARDCODED
(define ($bytevector-fill x i j fill) (define ($bytevector-fill x i j fill)

62
scheme/psyntax.expander.ss
View File

@ -779,15 +779,17 @@
(apply body ls/false) (apply body ls/false)
(syntax-match t (lits ...) cls* ...))))))))))) (syntax-match t (lits ...) cls* ...)))))))))))
(define parse-define (define parse-define
(lambda (x) (lambda (x)
;;; FIXME: (define f) is not supported yet
(syntax-match x () (syntax-match x ()
((_ (id . fmls) b b* ...) (id? id) ((_ (id . fmls) b b* ...) (id? id)
(values id (cons 'defun (cons fmls (cons b b*))))) (begin
(verify-formals fmls x)
(values id (cons 'defun (cons fmls (cons b b*))))))
((_ id val) (id? id) ((_ id val) (id? id)
(values id (cons 'expr val))) (values id (cons 'expr val)))
((_ id) (id? id) ((_ id) (id? id)
(values id (cons 'expr (bless '(void)))))))) (values id (cons 'expr (bless '(void))))))))
(define parse-define-syntax (define parse-define-syntax
@ -2630,33 +2632,43 @@
"attempt to assign to an unexportable variable")) "attempt to assign to an unexportable variable"))
(else (stx-error e)))))))) (else (stx-error e))))))))
(define (verify-formals fmls stx)
(syntax-match fmls ()
((x* ...)
(unless (valid-bound-ids? x*)
(invalid-fmls-error stx fmls)))
((x* ... . x)
(unless (valid-bound-ids? (cons x x*))
(invalid-fmls-error stx fmls)))
(_ (stx-error stx "invalid syntax"))))
(define chi-lambda-clause (define chi-lambda-clause
(lambda (stx fmls body* r mr) (lambda (stx fmls body* r mr)
(syntax-match fmls () (syntax-match fmls ()
((x* ...) ((x* ...)
(if (valid-bound-ids? x*) (begin
(let ((lex* (map gen-lexical x*)) (verify-formals fmls stx)
(lab* (map gen-label x*))) (let ((lex* (map gen-lexical x*))
(values (lab* (map gen-label x*)))
lex* (values
(chi-internal lex*
(add-subst (make-full-rib x* lab*) body*) (chi-internal
(add-lexicals lab* lex* r) (add-subst (make-full-rib x* lab*) body*)
mr))) (add-lexicals lab* lex* r)
(invalid-fmls-error stx fmls))) mr)))))
((x* ... . x) ((x* ... . x)
(if (valid-bound-ids? (cons x x*)) (begin
(let ((lex* (map gen-lexical x*)) (lab* (map gen-label x*)) (verify-formals fmls stx)
(lex (gen-lexical x)) (lab (gen-label x))) (let ((lex* (map gen-lexical x*)) (lab* (map gen-label x*))
(values (lex (gen-lexical x)) (lab (gen-label x)))
(append lex* lex) (values
(chi-internal (append lex* lex)
(add-subst (chi-internal
(make-full-rib (cons x x*) (cons lab lab*)) (add-subst
body*) (make-full-rib (cons x x*) (cons lab lab*))
(add-lexicals (cons lab lab*) (cons lex lex*) r) body*)
mr))) (add-lexicals (cons lab lab*) (cons lex lex*) r)
(invalid-fmls-error stx fmls))) mr)))))
(_ (stx-error fmls "invalid syntax"))))) (_ (stx-error fmls "invalid syntax")))))
(define chi-lambda-clause* (define chi-lambda-clause*