Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-20 14:19:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Distinguishing general read errors from incomplete input read errors.

Browse source 
Using these to allow multi-line input in edit-line.
This commit is contained in:
Alex Shinn 2014-05-05 21:05:02 +09:00
parent bb54932b5a
commit ea6e44f7d0
4 changed files with 44 additions and 25 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
lib/chibi/term/edit-line.scm
View file

@ -622,10 +622,14 @@
(buffer-insert! buf out ch)) (buffer-insert! buf out ch))
(define (command/enter ch buf out return) (define (command/enter ch buf out return)
(protect (exn (else (protect (exn
(buffer-clear buf out) ((and (exception? exn)
(print-exception exn out) (eq? 'read-incomplete (exception-kind exn)))
(buffer-draw buf out))) (command/self-insert ch buf out return))
(else
(buffer-clear buf out)
(print-exception exn out)
(buffer-draw buf out)))
(cond (cond
(((buffer-complete? buf) buf) (((buffer-complete? buf) buf)
(command/end-of-line ch buf out return) (command/end-of-line ch buf out return)

2
lib/chibi/term/edit-line.sld
View file

@ -7,5 +7,5 @@
buffer-clear buffer-refresh buffer-draw buffer-clear buffer-refresh buffer-draw
buffer-row buffer-col buffer-row buffer-col
make-keymap make-standard-keymap) make-keymap make-standard-keymap)
(import (chibi) (chibi stty) (chibi process) (srfi 9) (srfi 33)) (import (chibi) (chibi ast) (chibi stty) (chibi process) (srfi 9) (srfi 33))
(include "edit-line.scm")) (include "edit-line.scm"))

45
lib/srfi/38.scm
View file

@ -3,6 +3,11 @@
;; This code was written by Alex Shinn in 2009 and placed in the ;; This code was written by Alex Shinn in 2009 and placed in the
;; Public Domain. All warranties are disclaimed. ;; Public Domain. All warranties are disclaimed.
(define (raise-typed-error type)
(lambda (msg . args) (raise (make-exception type msg args #f #f))))
(define read-error (raise-typed-error 'read))
(define read-incomplete-error (raise-typed-error 'read-incomplete))
(define (extract-shared-objects x cyclic-only?) (define (extract-shared-objects x cyclic-only?)
(let ((seen (make-hash-table eq?))) (let ((seen (make-hash-table eq?)))
;; find shared references ;; find shared references
@ -141,7 +146,7 @@
(if (zero? depth) (read-char in) (skip-comment in (- depth 1))) (if (zero? depth) (read-char in) (skip-comment in (- depth 1)))
(skip-comment in depth))) (skip-comment in depth)))
(else (if (eof-object? (peek-char in)) (else (if (eof-object? (peek-char in))
(error "unterminated #| comment") (read-incomplete-error "unterminated #| comment")
(skip-comment in depth))))) (skip-comment in depth)))))
;; returns #f if a trailing # was consumed ;; returns #f if a trailing # was consumed
@ -194,7 +199,7 @@
(n (string->number str base)) (n (string->number str base))
(c (peek-char in))) (c (peek-char in)))
(if (or (not n) (not (or (eof-object? c) (memv c delimiters)))) (if (or (not n) (not (or (eof-object? c) (memv c delimiters))))
(error "read error: invalid number syntax" str c) (read-error "read error: invalid number syntax" str c)
n))) n)))
(define (read-float-tail in) ;; called only after a leading period (define (read-float-tail in) ;; called only after a leading period
(let lp ((res 0.0) (k 0.1)) (let lp ((res 0.0) (k 0.1))
@ -203,7 +208,7 @@
((char-numeric? c) ((char-numeric? c)
(lp (+ res (* (- (char->integer (read-char in)) (char->integer #\0)) k)) (* k 0.1))) (lp (+ res (* (- (char->integer (read-char in)) (char->integer #\0)) k)) (* k 0.1)))
((or (eof-object? c) (memv c delimiters)) res) ((or (eof-object? c) (memv c delimiters)) res)
(else (error "invalid char in float syntax" c)))))) (else (read-error "invalid char in float syntax" c))))))
(define (read-name c in) (define (read-name c in)
(let lp ((ls (if (char? c) (list c) '()))) (let lp ((ls (if (char? c) (list c) '())))
(let ((c (peek-char in))) (let ((c (peek-char in)))
@ -217,7 +222,7 @@
(string->number (substring name 1 (string-length name)) (string->number (substring name 1 (string-length name))
16)) 16))
=> integer->char) => integer->char)
(else (error "unknown char name" name))))) (else (read-error "unknown char name" name)))))
(define (read-type-id in) (define (read-type-id in)
(let ((ch (peek-char in))) (let ((ch (peek-char in)))
(cond (cond
@ -226,11 +231,11 @@
(let ((id (read in))) (let ((id (read in)))
(cond ((eq? id 't) #t) (cond ((eq? id 't) #t)
((integer? id) id) ((integer? id) id)
(else (error "invalid type identifier" id))))) (else (read-error "invalid type identifier" id)))))
((eqv? ch #\") ((eqv? ch #\")
(read in)) (read in))
(else (else
(error "invalid type identifier syntax" ch))))) (read-error "invalid type identifier syntax" ch)))))
(define (read-object) (define (read-object)
(let ((name (read-name #f in))) (let ((name (read-name #f in)))
(skip-whitespace in) (skip-whitespace in)
@ -240,7 +245,7 @@
(skip-whitespace in) (skip-whitespace in)
(cond (cond
((eof-object? (peek-char in)) ((eof-object? (peek-char in))
(error "missing closing }")) (read-error "missing closing }"))
((eqv? #\} (peek-char in)) ((eqv? #\} (peek-char in))
(read-char in) (read-char in)
(let ((res ((make-constructor #f type)))) (let ((res ((make-constructor #f type))))
@ -258,12 +263,12 @@
((#\#) ((#\#)
(read-char in) (read-char in)
(if (eof-object? (peek-char in)) (if (eof-object? (peek-char in))
(error "read error: incomplete # found at end of input")) (read-error "read error: incomplete # found at end of input"))
(case (char-downcase (peek-char in)) (case (char-downcase (peek-char in))
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
(let* ((str (read-label '())) (let* ((str (read-label '()))
(n (string->number str))) (n (string->number str)))
(if (not n) (error "read error: invalid reference" str)) (if (not n) (read-error "read error: invalid reference" str))
(cond (cond
((eqv? #\= (peek-char in)) ((eqv? #\= (peek-char in))
(read-char in) (read-char in)
@ -276,9 +281,9 @@
((eqv? #\# (peek-char in)) ((eqv? #\# (peek-char in))
(read-char in) (read-char in)
(cond ((assv n shared) => cdr) (cond ((assv n shared) => cdr)
(else (error "read error: unknown reference" n)))) (else (read-error "read error: unknown reference" n))))
(else (else
(error "read error: expected # after #n" (read-char in)))))) (read-error "read error: expected # after #n" (read-char in))))))
((#\;) ((#\;)
(read-char in) (read-char in)
(read-one) ;; discard (read-one) ;; discard
@ -301,18 +306,18 @@
((string-ci=? name "no-fold-case") ((string-ci=? name "no-fold-case")
(set-port-fold-case! in #f)) (set-port-fold-case! in #f))
(else ;; assume a #!/bin/bash line (else ;; assume a #!/bin/bash line
(error "unknown #! symbol" name))) (read-error "unknown #! symbol" name)))
(read-one)))))) (read-one))))))
((#\() (list->vector (read-one))) ((#\() (list->vector (read-one)))
((#\') (read-char in) (list 'syntax (read-one))) ((#\') (read-char in) (list 'syntax (read-one)))
((#\`) (read-char in) (list 'quasisyntax (read-one))) ((#\`) (read-char in) (list 'quasisyntax (read-one)))
((#\t) (let ((s (read-name #f in))) ((#\t) (let ((s (read-name #f in)))
(or (string-ci=? s "t") (string-ci=? s "true") (or (string-ci=? s "t") (string-ci=? s "true")
(error "bad # syntax" s)))) (read-error "bad # syntax" s))))
((#\f) (let ((s (read-name #f in))) ((#\f) (let ((s (read-name #f in)))
(if (or (string-ci=? s "f") (string-ci=? s "false")) (if (or (string-ci=? s "f") (string-ci=? s "false"))
#f #f
(error "bad # syntax" s)))) (read-error "bad # syntax" s))))
((#\d) (read-char in) (read in)) ((#\d) (read-char in) (read in))
((#\x) (read-char in) (read-number 16)) ((#\x) (read-char in) (read-number 16))
((#\o) (read-char in) (read-number 8)) ((#\o) (read-char in) (read-number 8))
@ -324,11 +329,11 @@
(read-char in)) (read-char in))
(read-char in) (read-char in)
(if (not (eqv? #\8 (peek-char in))) (if (not (eqv? #\8 (peek-char in)))
(error "invalid syntax #u" (peek-char in))) (read-error "invalid syntax #u" (peek-char in)))
(read-char in) (read-char in)
(let ((ls (read-one))) (let ((ls (read-one)))
(if (not (list? ls)) (if (not (list? ls))
(error "invalid bytevector syntax" ls)) (read-error "invalid bytevector syntax" ls))
(let* ((len (length ls)) (let* ((len (length ls))
(bv (make-bytevector len))) (bv (make-bytevector len)))
(do ((i 0 (+ i 1)) (ls ls (cdr ls))) (do ((i 0 (+ i 1)) (ls ls (cdr ls)))
@ -342,7 +347,7 @@
c1 c1
(read-named-char c1 in)))) (read-named-char c1 in))))
(else (else
(error "unknown # syntax: " (peek-char in))))) (read-error "unknown # syntax: " (peek-char in)))))
((#\() ((#\()
(read-char in) (read-char in)
(let lp ((res '())) (let lp ((res '()))
@ -364,15 +369,15 @@
(read-char in) (read-char in)
(append (reverse res) tail)) (append (reverse res) tail))
((eof-object? (peek-char in)) ((eof-object? (peek-char in))
(error "unterminated dotted list")) (read-incomplete-error "unterminated dotted list"))
(else (else
(error "expected end of list after dot"))))) (read-error "expected end of list after dot")))))
((char-numeric? (peek-char in)) ((char-numeric? (peek-char in))
(lp (cons (read-float-tail in) res))) (lp (cons (read-float-tail in) res)))
(else (lp (cons (string->symbol (read-name #\. in)) res))))) (else (lp (cons (string->symbol (read-name #\. in)) res)))))
(else (else
(if (eof-object? c) (if (eof-object? c)
(error "unterminated list") (read-incomplete-error "unterminated list")
(lp (cons (read-one) res)))))))) (lp (cons (read-one) res))))))))
((#\{) ((#\{)
(read-char in) (read-char in)

10
sexp.c
View file

@ -688,6 +688,16 @@ sexp sexp_read_error (sexp ctx, const char *msg, sexp ir, sexp port) {
return res; return res;
} }
sexp sexp_read_incomplete_error (sexp ctx, const char *msg, sexp ir, sexp port) {
sexp_gc_var1(res);
sexp_gc_preserve1(ctx, res);
res = sexp_read_error(ctx, msg, ir, port);
if (sexp_exceptionp(res))
sexp_exception_kind(res) = sexp_intern(ctx, "read-incomplete", -1);
sexp_gc_release1(ctx);
return res;
}
/*************************** list utilities ***************************/ /*************************** list utilities ***************************/
sexp sexp_cons_op (sexp ctx, sexp self, sexp_sint_t n, sexp head, sexp tail) { sexp sexp_cons_op (sexp ctx, sexp self, sexp_sint_t n, sexp head, sexp tail) {