Am 23.11.2013 11:28, schrieb "Jörg F. Wittenberger":
The attached patch
Which attached patch you ask?
Here we go.
--- kernel.scm.orig 2013-11-23 11:16:19.000000000 +0100
+++ kernel.scm 2013-11-23 11:17:14.000000000 +0100
@@ -176,6 +176,97 @@
(define-module (readable kernel)))
(else ))
+; Chicken compatible type annotations. Ignored on other platforms.
+(cond-expand
+ (chicken
+ (define-type :reader-proc: (input-port -> *))
+ (define-type :reader-token: (pair symbol *))
+ (define-type :reader-indent-token: (list string *))
+ (define-syntax no-values (syntax-rules () ((_) (void))))
+ )
+ (rscheme
+ (define-macro (: . x) #f)
+ (define-macro (no-values) (values))
+ )
+ (else
+ (define-syntax : (syntax-rules () ((_ . rest) #f)))
+ (define-syntax no-values (syntax-rules () ((_) (if #f #t))))
+ ))
+
+; Implementation specific extension to flush output on ports.
+(cond-expand
+ (guile ; Don't use define-syntax, that doesn't work on all guiles
+ (define (flush-output-port port) ; this is the only format we need.
+ (force-output port)))
+ (chicken
+ (define-syntax flush-output-port
+ (syntax-rules () ((_ port) (flush-output port)))))
+ (else ))
+
+; Special cases for those Scheme implementations which do that not
+; support define-syntax.
+; Note that guile is a large special case further down.
+
+(cond-expand
+ (rscheme
+
+ (define-macro (readable-kernel-module-contents exports . body)
+ `(begin ;; (export ,@exports)
+ ,@body))
+
+ (define-macro (let-splitter (full first-value second-value) expr . body)
+ `(let* ((,full ,expr)
+ (,first-value (car ,full))
+ (,second-value (cadr ,full)))
+ . ,body))
+ )
+ (else
+ ; assume R5RS with define-syntax
+
+ ; On R6RS, and other Scheme's, module contents must
+ ; be entirely inside a top-level module structure.
+ ; Use module-contents to support that. On Schemes
+ ; where module declarations are separate top-level
+ ; expressions, we expect module-contents to transform
+ ; to a simple (begin ...), and possibly include
+ ; whatever declares exported stuff on that Scheme.
+ (define-syntax readable-kernel-module-contents
+ (syntax-rules ()
+ ((readable-kernel-module-contents exports body ...)
+ (begin body ...))))
+ ; There is no standard Scheme mechanism to unread multiple characters.
+ ; Therefore, the key productions and some of their supporting procedures
+ ; return both the information on what ended their reading process,
+ ; as well the actual value (if any) they read before whatever stopped them.
+ ; That way, procedures can process the value as read, and then pass on
+ ; the ending information to whatever needs it next. This approach,
+ ; which we call a "non-tokenizing" implementation, implements a tokenizer
+ ; via procedure calls instead of needing a separate tokenizer.
+ ; The ending information can be:
+ ; - "stopper" - this is returned by productions etc. that do NOT
+ ; read past the of a line (outside of paired characters and strings).
+ ; It is 'normal if it ended normally (e.g., at end of line); else it's
+ ; 'sublist-marker ($), 'group-split-marker (\\), 'collecting (<*),
+ ; 'collecting-end (*>), 'scomment (special comments like #|...|#), or
+ ; 'abbrevw (initial abbreviation with whitespace after it).
+ ; - "new-indent" - this is returned by productions etc. that DO read
+ ; past the end of a line. Such productions typically read the
+ ; next line's indent to determine if they should return.
+ ; If they should, they return the new indent so callers can
+ ; determine what to do next. A "*>" should return even though its
+ ; visible indent level is length 0; we handle this by prepending
+ ; all normal indents with "^", and "*>" generates a length-0 indent
+ ; (which is thus shorter than even an indent of 0 characters).
+
+ (define-syntax let-splitter
+ (syntax-rules ()
+ ((let-splitter (full first-value second-value) expr body ...)
+ (let* ((full expr)
+ (first-value (car full))
+ (second-value (cadr full)))
+ body ...))))
+ ))
+
(cond-expand
; -----------------------------------------------------------------------------
; Guile Compatibility
@@ -243,10 +334,6 @@
(debug-set! stack 500000)
(no-values))
- ; Implementation specific extension to flush output on ports.
- (define (flush-output-port port) ; this is the only format we need.
- (force-output port))
-
; Guile was the original development environment, so the algorithm
; practically acts as if it is in Guile.
; Needs to be lambdas because otherwise Guile 2.0 acts strangely,
@@ -455,52 +542,15 @@
(define (type-of x) #f)
(define (type? x) #f)
- (define (string->keyword s)
- (symbol->keyword (string->symbol s)))
-
)
; -----------------------------------------------------------------------------
; R5RS Compatibility
; -----------------------------------------------------------------------------
(else
- ; assume R5RS with define-syntax
-
- ; On R6RS, and other Scheme's, module contents must
- ; be entirely inside a top-level module structure.
- ; Use module-contents to support that. On Schemes
- ; where module declarations are separate top-level
- ; expressions, we expect module-contents to transform
- ; to a simple (begin ...), and possibly include
- ; whatever declares exported stuff on that Scheme.
- (define-syntax readable-kernel-module-contents
- (syntax-rules ()
- ((readable-kernel-module-contents exports body ...)
- (begin body ...))))
-
- ; We include chicken compatible type annotations (":"), per
- ; http://wiki.call-cc.org/man/4/Types
- ; These are ignored on other platforms.
- (cond-expand
- (chicken
- (define-type :reader-proc: (input-port -> *))
- (define-type :reader-token: (pair symbol *))
- (define-type :reader-indent-token: (list string *))
- (define-syntax no-values (syntax-rules () ((_) (void))))
- )
- (else
- (define-syntax : (syntax-rules ((_ . rest) #f)))
- (define-syntax no-values (syntax-rules () ((_) (if #f #t))))))
; A do-nothing.
(define (init-sweet) (no-values))
- ; Implementation specific extension to flush output on ports.
- (cond-expand
- (chicken
- (define-syntax flush-output-port
- (syntax-rules () ((_ port) (flush-output port)))))
- (else ))
-
; We use my-* procedures so that the
; "port" automatically keeps track of source position.
; On Schemes where that is not true (e.g. Racket, where
@@ -535,11 +585,6 @@
(define (get-sourceinfo _) #f)
(define (attach-sourceinfo _ x) x)
- ; Not strictly R5RS but we expect at least some Schemes
- ; to allow this somehow.
- (define (replace-read-with f)
- (set! read f))
-
; R5RS has no hash extensions
(define (parse-hash no-indent-read char fake-port) #f)
@@ -555,7 +600,31 @@
; Somehow get SRFI-69 and SRFI-1
))
+(cond-expand
+ (guile
+ ; Handled in the guile specific section.
+ )
+ (rscheme
+ ; Not strictly R5RS but and RScheme complains.
+ ; FIXME: figure out what to do.
+ (define (replace-read-with f)
+ #f ;; (set! read f)
+ )
+ )
+ (else
+ ; Not strictly R5RS but we expect at least some Schemes
+ ; to allow this somehow.
+ (define (replace-read-with f)
+ (set! read f))
+ ))
+
+; keyword creation
+(cond-expand
+ ((or guile rscheme)
+ (define (string->keyword s)
+ (symbol->keyword (string->symbol s))))
+ (else ))
; -----------------------------------------------------------------------------
; Module declaration and useful utilities
@@ -1194,13 +1263,12 @@
; Translate "x" to Common Lisp representation if we're printing CL.
; Basically we use a very unusual representation, and then translate it back
- (: translate-cl (* --> *))
(define translate-cl
(let ((qq (string->symbol "+++CL-QUASIQUOTE-abbreviation+++"))
(uq (string->symbol "+++CL-UNQUOTE-abbreviation+++"))
(us (string->symbol "+++CL-UNQUOTE-SPLICING-abbreviation+++")))
(lambda (x)
- (if common-lisp
+ (if (common-lisp)
(case x
((quasiquote) qq)
((unquote) uq)
@@ -1588,37 +1656,6 @@
; Sweet Expressions (this implementation maps to the BNF)
; -----------------------------------------------------------------------------
- ; There is no standard Scheme mechanism to unread multiple characters.
- ; Therefore, the key productions and some of their supporting procedures
- ; return both the information on what ended their reading process,
- ; as well the actual value (if any) they read before whatever stopped them.
- ; That way, procedures can process the value as read, and then pass on
- ; the ending information to whatever needs it next. This approach,
- ; which we call a "non-tokenizing" implementation, implements a tokenizer
- ; via procedure calls instead of needing a separate tokenizer.
- ; The ending information can be:
- ; - "stopper" - this is returned by productions etc. that do NOT
- ; read past the of a line (outside of paired characters and strings).
- ; It is 'normal if it ended normally (e.g., at end of line); else it's
- ; 'sublist-marker ($), 'group-split-marker (\\), 'collecting (<*),
- ; 'collecting-end (*>), 'scomment (special comments like #|...|#), or
- ; 'abbrevw (initial abbreviation with whitespace after it).
- ; - "new-indent" - this is returned by productions etc. that DO read
- ; past the end of a line. Such productions typically read the
- ; next line's indent to determine if they should return.
- ; If they should, they return the new indent so callers can
- ; determine what to do next. A "*>" should return even though its
- ; visible indent level is length 0; we handle this by prepending
- ; all normal indents with "^", and "*>" generates a length-0 indent
- ; (which is thus shorter than even an indent of 0 characters).
-
- (define-syntax let-splitter
- (syntax-rules ()
- ((let-splitter (full first-value second-value) expr body ...)
- (let* ((full expr)
- (first-value (car full))
- (second-value (cadr full)))
- body ...))))
; Note: If your Lisp has macros, but doesn't support hygenic macros,
; it's probably trivial to reimplement this. E.G., in Common Lisp:
; (defmacro let-splitter ((full first-value second-value) expr &rest body)
@@ -1703,13 +1740,13 @@
(let* ((consumed-sharp (my-read-char port))
(result (process-sharp neoteric-read-nocomment port)))
(cond
+ ((not (pair? result)) (read-error "Unsupported hash"))
((eq? (car result) 'normal)
(list 'normal (neoteric-process-tail port (cadr result))))
((eq? (car result) 'abbrev)
(list 'normal
(list (cadr result) (neoteric-read-nocomment port))))
- ((pair? result) result)
- (else (read-error "Unsupported hash"))))
+ (else result)))
(list 'normal (neoteric-read-nocomment port))))
; Read an n-expression. Returns ('normal n-expr) in most cases;
@@ -2009,8 +2046,8 @@
(else (list 'normal (list basic-value))))))
; Returns (new-indent computed-value)
- (: body (input-port string -> :reader-token:))
- (define (body port starting-indent)
+ (: read-body (input-port string -> :reader-token:))
+ (define (read-body port starting-indent)
(let-splitter (i-full-results i-new-indent i-value)
(it-expr port starting-indent)
(if (string=? starting-indent i-new-indent)
@@ -2021,9 +2058,9 @@
(read-error "Dedent required after lone . and value line"))
(list f-new-indent f-value)) ; final value of improper list
(if (eq? i-value empty-value)
- (body port i-new-indent)
+ (read-body port i-new-indent)
(let-splitter (nxt-full-results nxt-new-indent nxt-value)
- (body port i-new-indent)
+ (read-body port i-new-indent)
(list nxt-new-indent (cons i-value nxt-value)))))
(list i-new-indent (list1e i-value))))) ; dedent - end list.
@@ -2058,7 +2095,7 @@
(let ((new-indent (get-next-indent port)))
(if (indentation>? new-indent starting-indent)
(let-splitter (body-full body-new-indent body-value)
- (body port new-indent)
+ (read-body port new-indent)
(list body-new-indent (my-append line-value body-value)))
(list new-indent (monify line-value)))))
(else
@@ -2077,7 +2114,7 @@
(if (indentation>? new-indent starting-indent)
(let-splitter
(body-full-results body-new-indent body-value)
- (body port new-indent)
+ (read-body port new-indent)
(list body-new-indent empty-value))
(read-error "#;+EOL must be followed by indent"))))))
((or (eq? line-stopper 'group-split-marker)
@@ -2088,7 +2125,7 @@
(let ((new-indent (get-next-indent port)))
(cond
((indentation>? new-indent starting-indent)
- (body port new-indent))
+ (read-body port new-indent))
(else
(list new-indent empty-value))))))
((eq? line-stopper 'sublist-marker)
@@ -2105,7 +2142,7 @@
(if (not (indentation>? new-indent starting-indent))
(read-error "Indent required after abbreviation"))
(let-splitter (ab-full-results ab-new-indent ab-value)
- (body port new-indent)
+ (read-body port new-indent)
(list ab-new-indent
(append (list line-value) ab-value))))
(let-splitter (ai-full-results ai-new-indent ai-value)
------------------------------------------------------------------------------
Shape the Mobile Experience: Free Subscription
Software experts and developers: Be at the forefront of tech innovation.
Intel(R) Software Adrenaline delivers strategic insight and game-changing
conversations that shape the rapidly evolving mobile landscape. Sign up now.
http://pubads.g.doubleclick.net/gampad/clk?id=63431311&iu=/4140/ostg.clktrk
_______________________________________________
Readable-discuss mailing list
Readable-discuss@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/readable-discuss
