From a43177d39987fcede11f52b1aa27b724eca7213a Mon Sep 17 00:00:00 2001
From: Abdulaziz Ghuloum <aghuloum@cs.indiana.edu>
Date: Sun, 27 Jan 2008 19:12:20 -0500
Subject: [PATCH] Fixed some of bug 186155: Incorrect syntax errors for define

---
 scheme/ikarus.bytevectors.ss |  2 +-
 scheme/psyntax.expander.ss   | 62 +++++++++++++++++++++---------------
 2 files changed, 38 insertions(+), 26 deletions(-)

diff --git a/scheme/ikarus.bytevectors.ss b/scheme/ikarus.bytevectors.ss
index f46c303..0fbb80f 100644
--- a/scheme/ikarus.bytevectors.ss
+++ b/scheme/ikarus.bytevectors.ss
@@ -73,7 +73,7 @@
     (ikarus system $pairs)
     (ikarus system $bytevectors))
 
-  (define (native-endianness) 'big) ;;; HARDCODED
+  (define (native-endianness) 'little) ;;; HARDCODED
 
 
   (define ($bytevector-fill x i j fill)
diff --git a/scheme/psyntax.expander.ss b/scheme/psyntax.expander.ss
index 62ea874..7f53ff4 100644
--- a/scheme/psyntax.expander.ss
+++ b/scheme/psyntax.expander.ss
@@ -779,15 +779,17 @@
                        (apply body ls/false)
                        (syntax-match t (lits ...) cls* ...)))))))))))
 
+    
   (define parse-define
     (lambda (x)
-      ;;; FIXME:  (define f) is not supported yet
       (syntax-match x ()
         ((_ (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)
          (values id (cons 'expr val)))
-        ((_ id) (id? id) 
+        ((_ id) (id? id)
          (values id (cons 'expr (bless '(void))))))))
 
   (define parse-define-syntax
@@ -2630,33 +2632,43 @@
                 "attempt to assign to an unexportable variable"))
              (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
     (lambda (stx fmls body* r mr)
       (syntax-match fmls ()
         ((x* ...)
-         (if (valid-bound-ids? x*)
-             (let ((lex* (map gen-lexical x*))
-                   (lab* (map gen-label x*)))
-               (values
-                 lex*
-                 (chi-internal
-                   (add-subst (make-full-rib x* lab*) body*)
-                   (add-lexicals lab* lex* r)
-                   mr)))
-             (invalid-fmls-error stx fmls)))
+         (begin
+           (verify-formals fmls stx)
+           (let ((lex* (map gen-lexical x*))
+                 (lab* (map gen-label x*)))
+             (values
+               lex*
+               (chi-internal
+                 (add-subst (make-full-rib x* lab*) body*)
+                 (add-lexicals lab* lex* r)
+                 mr)))))
         ((x* ... . x)
-         (if (valid-bound-ids? (cons x x*))
-             (let ((lex* (map gen-lexical x*)) (lab* (map gen-label x*))
-                   (lex (gen-lexical x)) (lab (gen-label x)))
-               (values
-                 (append lex* lex)
-                 (chi-internal
-                   (add-subst
-                     (make-full-rib (cons x x*) (cons lab lab*))
-                     body*)
-                   (add-lexicals (cons lab lab*) (cons lex lex*) r)
-                   mr)))
-             (invalid-fmls-error stx fmls)))
+         (begin
+           (verify-formals fmls stx)
+           (let ((lex* (map gen-lexical x*)) (lab* (map gen-label x*))
+                 (lex (gen-lexical x)) (lab (gen-label x)))
+             (values
+               (append lex* lex)
+               (chi-internal
+                 (add-subst
+                   (make-full-rib (cons x x*) (cons lab lab*))
+                   body*)
+                 (add-lexicals (cons lab lab*) (cons lex lex*) r)
+                 mr)))))
         (_ (stx-error fmls "invalid syntax")))))
   
   (define chi-lambda-clause*