The attached diff makes the whole thing compile under rscheme too (and
run some simple tests).
No changes where made, which where not strictly necessary to that end.
I'm sure you'll take issues with the positioning of cond-expand'ed stuff.
I tried for now to keep the compatibility layer before the actual
module. But that might leak definitions (like the rudimentary guard
implementation) outside, which would have to be avoided. For this to we
would have to move the whole section into the body of
`readable-kernel-module-contents`, right?
Best Regards
/Jörg
--- kernel.scm.orig 2013-11-21 12:19:00.000000000 +0100
+++ kernel.scm 2013-11-21 12:20:03.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,51 +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 (":").
- ; 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
@@ -534,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)
@@ -554,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
@@ -626,7 +696,7 @@
(define literal-barred-symbol #f)
; Returns a true value (not necessarily #t)
- (: char-line-ending? ((or char eof) --> boolean))
+ (: char-line-ending? (* --> boolean))
(define (char-line-ending? char) (memv char line-ending-chars))
; Create own version, in case underlying implementation omits some.
@@ -650,7 +720,7 @@
((eqv? c linefeed)
(my-read-char port)))))
- (: consume-to-eol (input-port -> *)) ; FIXME
+ (: consume-to-eol (input-port -> undefined))
(define (consume-to-eol port)
; Consume every non-eol character in the current line.
; End on EOF or end-of-line char.
@@ -807,7 +877,7 @@
#\" #\;) ; Could add #\# or #\|
whitespace-chars))
- (: consume-whitespace (input-port ->))
+ (: consume-whitespace (input-port -> undefined))
(define (consume-whitespace port)
(let ((char (my-peek-char port)))
(cond
@@ -837,7 +907,6 @@
(display message (current-error-port))
(newline (current-error-port))
(flush-output-port (current-error-port))
- ; Guile extension, but many Schemes have exceptions
(raise 'readable)
'())
@@ -944,7 +1013,7 @@
(my-string-foldcase s)
s))
- (: process-directive (string ->))
+ (: process-directive (string -> undefined))
(define (process-directive dir)
(cond
; TODO: These should be specific to the port.
@@ -970,7 +1039,7 @@
; Consume characters until "!#"
;; FIXME other procedures skipping chars have names beginning with consume- here.!
- (: non-nest-comment (input-port ->))
+ (: non-nest-comment (input-port -> undefined))
(define (non-nest-comment port)
(let ((c (my-read-char port)))
(cond
@@ -1194,17 +1263,21 @@
; Translate "x" to Common Lisp representation if we're printing CL.
; Basically we use a very unusual representation, and then translate it back
- (define (translate-cl x)
- (if common-lisp
- (case x
- ((quasiquote) '+++CL-QUASIQUOTE-abbreviation+++)
- ((unquote) '+++CL-UNQUOTE-abbreviation+++)
- ((unquote-splicing) '+++CL-UNQUOTE-SPLICING-abbreviation+++)
- (else x))
- x))
+ (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)
+ (case x
+ ((quasiquote) qq)
+ ((unquote) uq)
+ ((unquote-splicing) us)
+ (else x))
+ x))))
; detect #| or |#
- (: nest-comment (input-port ->))
+ (: nest-comment (input-port -> undefined))
(define (nest-comment fake-port)
(let ((c (my-read-char fake-port)))
(cond
@@ -1458,7 +1531,7 @@
; Not a simple infix list - transform it. Written as a separate procedure
; so that future experiments or SRFIs can easily replace just this piece.
- (: transform-mixed-infix (list --> list))
+ (: transform-mixed-infix (list --> :reader-token:))
(define (transform-mixed-infix lyst)
(cons '$nfx$ lyst))
@@ -1583,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)
@@ -1643,7 +1685,7 @@
(memv c initial-comment-eol)))
; Return #t if char is space or tab.
- (: char-hspace? (char -> boolean))
+ (: char-hspace? (char --> boolean))
(define (char-hspace? char)
(or (eqv? char #\space)
(eqv? char tab)))
@@ -1657,7 +1699,7 @@
(hspaces port))))
; Return #t if char is space, tab, or !
- (: char-hspace? (char -> boolean))
+ (: char-hspace? (char --> boolean))
(define (char-ichar? char)
(or (eqv? char #\space)
(eqv? char tab)
@@ -2004,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)
@@ -2016,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.
@@ -2053,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
@@ -2072,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)
@@ -2083,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)
@@ -2100,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
