[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