[gambit-list] gsc segfaults

Ramil Farkhshatov ramil at gmx.co.uk
Thu Aug 27 10:02:42 EDT 2009


On Thu, Aug 27, 2009 at 12:40:47PM +0200, Ralf Schmitt wrote:
> Hi all,
> 
> I get a segfault when trying to compile srfi-13:
> 
> $ curl -O http://srfi.schemers.org/srfi-13/srfi-13.scm
> $ gsc -e '(load "~~/lib/syntax-case.scm")' srfi-13.scm
> zsh: segmentation fault  gsc -e '(load "~~/lib/syntax-case.scm")' srfi-13.scm
> 
> 
> this happens with gambit v4.5.1 on a x86-64 arch linux using gcc 4.4.1.
> 

Encountered same issue on archlinux i686 and gambit v4.4.3.
Here is patch for srfi-pack. Colleague ported srfi-13 to 
define-macro.

-- 
Ramil Farkhshatov

-------------- next part --------------
diff --git a/srfi-13.scm b/srfi-13.scm
index 9840038..5804ed7 100644
--- a/srfi-13.scm
+++ b/srfi-13.scm
@@ -121,24 +121,42 @@
 ;;; This macro parses optional start/end arguments from arg lists, defaulting
 ;;; them to 0/(string-length s), and checks them for correctness.
 
-(define-syntax let-string-start+end
-  (syntax-rules ()
-    ((let-string-start+end (start end) proc s-exp args-exp body ...)
-     (receive (start end) (string-parse-final-start+end proc s-exp args-exp)
-       body ...))
-    ((let-string-start+end (start end rest) proc s-exp args-exp body ...)
-     (receive (rest start end) (string-parse-start+end proc s-exp args-exp)
-       body ...))))
+(define-macro (let-string-start+end args proc s-exp args-exp . body)
+    (case (length args)
+	((2) `(receive ,args 
+			(string-parse-final-start+end ,proc ,s-exp ,args-exp)
+    			, at body))
+	((3) `(receive ,args 
+			(string-parse-start+end ,proc ,s-exp ,args-exp)
+    			, at body))
+	(else (error "Wrong syntax for let-string-start+end"))))
+
+;;(define-syntax let-string-start+end
+;;  (syntax-rules ()
+;;    ((let-string-start+end (start end) proc s-exp args-exp body ...)
+;;     (receive (start end) (string-parse-final-start+end proc s-exp args-exp)
+;;       body ...))
+;;    ((let-string-start+end (start end rest) proc s-exp args-exp body ...)
+;;    (receive (rest start end) (string-parse-start+end proc s-exp args-exp)
+;;       body ...))))
 
 ;;; This one parses out a *pair* of final start/end indices. 
 ;;; Not exported; for internal use.
-(define-syntax let-string-start+end2
-  (syntax-rules ()
-    ((l-s-s+e2 (start1 end1 start2 end2) proc s1 s2 args body ...)
-     (let ((procv proc)) ; Make sure PROC is only evaluated once.
-       (let-string-start+end (start1 end1 rest) procv s1 args
-         (let-string-start+end (start2 end2) procv s2 rest
-           body ...))))))
+
+(define-macro (let-string-start+end2 argspos proc s1 s2 args . body)
+    (let ((rest (gensym)))
+    `(let ((procv ,proc)) ; Make sure PROC is only evaluated once.
+       (let-string-start+end (,(car argspos) ,(cadr argspos) ,rest) procv ,s1 ,args
+         (let-string-start+end (,(caddr argspos) ,(cadddr argspos)) procv ,s2 ,rest
+           , at body)))))
+
+;;(define-syntax let-string-start+end2
+;;  (syntax-rules ()
+;;    ((l-s-s+e2 (start1 end1 start2 end2) proc s1 s2 args body ...)
+;;     (let ((procv proc)) ; Make sure PROC is only evaluated once.
+;;       (let-string-start+end (start1 end1 rest) procv s1 args
+;;         (let-string-start+end (start2 end2) procv s2 rest
+;;           body ...))))))
 
 
 ;;; Returns three values: rest start end
diff --git a/srfi-14.scm b/srfi-14.scm
index 0e33ec1..60f3d8e 100644
--- a/srfi-14.scm
+++ b/srfi-14.scm
@@ -67,6 +67,61 @@
 ;;; See the end of the file for porting and performance-tuning notes.
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
+(define (%latin1->char char)
+(integer->char char)
+)
+
+(define (%char->latin1 char)
+(char->integer char)
+)
+
+(define-macro (let-optionals* datum args . body)
+    (let ((arg-name (gensym)))
+    (let loop ((args args)
+		       (let-arguments '())
+               (set-let '())
+	           (if-checking '()))
+	(if (pair? args)
+	    (cond
+            ((and (not (pair? (car args))) (not (pair? (cdr args))))
+                ;; rest
+                (loop (cdr args) 
+                      (cons `(,(car args) '()) let-arguments)
+                      (cons `(if (pair? ,arg-name) (set! ,(car args) ,arg-name)) set-let)
+                      if-checking))
+            ((and (pair? (car args)) (equal? (length (car args)) 2))
+                ;; without checking
+                (loop (cdr args) 
+                      (cons (list (caar args) (cadar args)) let-arguments)
+                      (cons `(if (pair? ,arg-name) (begin (set! ,(caar args) (car ,arg-name)) (set! ,arg-name (cdr ,arg-name)))) set-let)
+                      if-checking))
+            ((and (pair? (car args)) (equal? (length (car args)) 3))
+                ;; with checking
+                (loop (cdr args) 
+                      (cons (list (caar args) (cadar args)) let-arguments)
+                      (cons `(if (pair? ,arg-name) (begin (set! ,(caar args) (car ,arg-name)) (set! ,arg-name (cdr ,arg-name)))) set-let)
+                      (cons (caddar args) if-checking)))
+            (else (error "invalid let-optionals*")))
+	    `(let ((,arg-name ,datum))
+            (let* (,@(reverse let-arguments))
+            ,@(reverse set-let)
+		(if (and #t ,@(reverse if-checking))
+		    (begin , at body)
+		    (error "wrong arguments"))))))))
+
+(define-macro (:optional . args)
+    (case (length args)
+        ((2)
+            `(if (equal? ,(car args) '()) ,(cadr args) ,(car args))
+        )
+        ((3)
+            `(if (and (not (equal? ,(car args) '())) 
+                    (,(caddr args) ,(car args))) ,(car args) ,(cadr args)))
+        (else "wrong arguments passed to :optional")))
+
+(define-macro (check-arg . rest)
+    (void))
+
 (define-record-type :char-set
   (make-char-set s)
   char-set?
@@ -338,7 +393,7 @@
 	    chars))
 
 (define (char-set . chars)
-  (let ((s (make-string 256 c0)))
+  (let ((s (make-string 256 #\nul)))
     (%list->char-set! chars s)
     (make-char-set s)))
 


More information about the Gambit-list mailing list