In an attempt to better understand and document the source code I added
type annotations (using the chicken's syntax and using chicken to verify
it).
So far I'm only through to the read-related procedures.
But it's so much, I solicit comments from those who know the code.
At least it still compiles and works, even using chickens -strict-types
mode (which, in between when there was one badly broken type
declaration, did already result in non-working code --- supporting my
understanding that chicken's -strict-types mode is not a noop.).
--- kernel.scm.orig 2013-11-17 21:23:38.000000000 +0100
+++ kernel.scm 2013-11-17 21:23:52.000000000 +0100
@@ -176,6 +176,17 @@
(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 *))
+ )
+ (else
+ (define-syntax : (syntax-rules ((_ . rest) #f)))
+ ))
+
; Implementation specific extension to flush output on ports.
(cond-expand
(guile ; Don't use define-syntax, that doesn't work on all guiles
@@ -594,9 +605,11 @@
(define keyword-syntax (make-parameter #f))
; Returns a true value (not necessarily #t)
+ (: char-line-ending? (* --> boolean))
(define (char-line-ending? char) (memv char line-ending-chars))
; Create own version, in case underlying implementation omits some.
+ (: my-char-whitespace? (char --> boolean))
(define (my-char-whitespace? c)
(or (char-whitespace? c) (memv c whitespace-chars)))
@@ -605,16 +618,18 @@
; guile use annoying (EOF won't be correctly detected) due to a guile bug
; (in guile before version 2.0.8, peek-char incorrectly
; *consumes* EOF instead of just peeking).
+ (: consume-end-of-line (input-port -> *))
(define (consume-end-of-line port)
(let ((c (my-peek-char port)))
(cond
((eqv? c carriage-return)
- (my-read-char port)
+ (my-read-char port)
(if (eqv? (my-peek-char port) linefeed)
(my-read-char port)))
((eqv? c linefeed)
(my-read-char port)))))
+ (: consume-to-eol (input-port -> *)) ; FIXME
(define (consume-to-eol port)
; Consume every non-eol character in the current line.
; End on EOF or end-of-line char.
@@ -625,6 +640,7 @@
(my-read-char port)
(consume-to-eol port)))))
+ (: consume-to-whitespace (input-port -> (or eof null)))
(define (consume-to-whitespace port)
; Consume to whitespace
(let ((c (my-peek-char port)))
@@ -648,6 +664,7 @@
(display "\n")))
data)
+ (: my-read-delimited-list (:reader-proc: char input-port -> *))
(define (my-read-delimited-list my-read stop-char port)
; Read the "inside" of a list until its matching stop-char, returning list.
; stop-char needs to be closing paren, closing bracket, or closing brace.
@@ -690,7 +707,9 @@
; Read preservation, replacement, and mode setting
; -----------------------------------------------------------------------------
+ (: default-scheme-read :reader-proc:)
(define default-scheme-read read)
+ (: replace-read :reader-proc:)
(define replace-read replace-read-with)
(define (restore-traditional-read) (replace-read-with default-scheme-read))
@@ -708,8 +727,9 @@
(define (enable-sweet)
(replace-read sweet-read))
- (define current-read-mode #f)
+ (define current-read-mode #f) ;; OBSOLETE?
+ (: set-read-mode deprecated) ; not yet, just as a marker for the open questions
(define (set-read-mode mode port)
; TODO: Should be per-port
(cond
@@ -764,17 +784,20 @@
#\" #\;) ; Could add #\# or #\|
whitespace-chars))
+ (: consume-whitespace (input-port ->))
(define (consume-whitespace port)
(let ((char (my-peek-char port)))
(cond
- ((eof-object? char))
+ ((eof-object? char) (values))
((eqv? char #\;)
(consume-to-eol port)
(consume-whitespace port))
((my-char-whitespace? char)
(my-read-char port)
- (consume-whitespace port)))))
+ (consume-whitespace port))
+ (else (values)))))
+ (: read-until-delim (input-port (list-of char) -> (list-of char)))
(define (read-until-delim port delims)
; Read characters until eof or a character in "delims" is seen.
; Do not consume the eof or delimiter.
@@ -785,6 +808,7 @@
((memv c delims) '())
(else (my-read-char port) (cons c (read-until-delim port delims))))))
+ (: read-error (* -> . *))
(define (read-error message)
(display "Error: " (current-error-port))
(display message (current-error-port))
@@ -795,20 +819,30 @@
; Return the number by reading from port, and prepending starting-lyst.
; Returns #f if it's not a number.
+ (: read-number (input-port (list-of char) -> (or number boolean)))
(define (read-number port starting-lyst)
(string->number (list->string
(append starting-lyst
(read-until-delim port neoteric-delimiters)))))
; Return list of digits read from port; may be empty.
+ (: read-digits (input-port -> (or (pair (or eof char) *) null)))
(define (read-digits port)
(let ((c (my-peek-char port)))
(cond
+ ;; XXX At this low level I bet it would be much better to have
+ ;; the compiler code the test inline like this:
+ ;;
+ ;; (case c
+ ;; ((#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
+ ;; (else #f))
((memv c digits)
(cons (my-read-char port) (read-digits port)))
(else '()))))
+ ;; XXX See comment in read-digits: It might be a good idea to use
+ ;; someting better than a-lists at such frequent executed code.
(define char-name-values
; Includes standard names and guile extensions; see
; http://www.gnu.org/software/guile/manual/html_node/Characters.html
@@ -864,6 +898,7 @@
; It's also required by the Common Lisp spec.
(rubout #x007f)))
+ (: process-char (input-port -> (or eof char null)))
(define (process-char port)
; We've read #\ - returns what it represents.
(cond
@@ -886,11 +921,13 @@
; Otherwise, just return "s". This is needed to support our
; is-foldcase configuration value when processing symbols.
; TODO: Should be port-specific
+ (: fold-case-maybe (input-port string -> string))
(define (fold-case-maybe port s)
(if (is-foldcase)
(my-string-foldcase s)
s))
+ (: process-directive (string ->))
(define (process-directive dir)
(cond
; TODO: These should be specific to the port.
@@ -907,6 +944,8 @@
(else (display "Warning: Unknown process directive"))))
; Consume characters until "!#"
+ ;; XXX other procedures skipping chars have names beginning with consume- here.!
+ (: non-nest-comment (input-port ->))
(define (non-nest-comment port)
(let ((c (my-read-char port)))
(cond
@@ -922,6 +961,7 @@
(else
(non-nest-comment port)))))
+ (: process-sharp-bang (input-port -> :reader-token:))
(define (process-sharp-bang port)
(let ((c (my-peek-char port)))
(cond
@@ -1001,8 +1041,10 @@
(gobble-chars port (cdr to-gobble)))
(else (length to-gobble)))))
+ (: scomment-result :reader-token:)
(define scomment-result '(scomment ()))
+ (: process-sharp (:reader-proc: input-port -> *))
(define (process-sharp no-indent-read port)
; We've read a # character. Returns what it represents as
; (stopper value); ('normal value) is value, ('scomment ()) is comment.
@@ -1024,6 +1066,7 @@
(parse-default no-indent-read c port)
(read-error "Invalid #-prefixed string"))))))
+ (: parse-default (:reader-proc: char input-port -> *))
(define (parse-default no-indent-read c port)
(cond ; Nothing special - use generic rules
((char-ci=? c #\t)
@@ -1105,6 +1148,7 @@
scomment-result) ; Return comment
(else #f)))
+ (: parse-cl (:reader-proc: char input-port -> (or (list symbol symbol) boolean)))
(define (parse-cl no-indent-read c port)
; These are for Common Lisp; the "unsweeten" program
; can deal with the +++ ones.
@@ -1135,6 +1179,7 @@
x))
; detect #| or |#
+ (: nest-comment (input-port ->))
(define (nest-comment fake-port)
(let ((c (my-read-char fake-port)))
(cond
@@ -1158,8 +1203,10 @@
(else
(nest-comment fake-port)))))
+ (: digits (list-of char))
(define digits '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
+ (: process-period (input-port -> (or number boolean null symbol)))
(define (process-period port)
; We've peeked a period character. Returns what it represents.
(my-read-char port) ; Remove .
@@ -1181,6 +1228,7 @@
(read-until-delim port neoteric-delimiters)))))))))
; Read an inline hex escape (after \x), return the character it represents
+ (: read-inline-hex-escape (input-port -> char))
(define (read-inline-hex-escape port)
(let* ((chars (read-until-delim port (append neoteric-delimiters '(#\;))))
(n (string->number (list->string chars) 16)))
@@ -1193,6 +1241,7 @@
; We're inside |...| ; return the list of characters inside.
; Do NOT call fold-case-maybe, because we always use literal values here.
+ (: read-symbol-elements (input-port -> (list-of char)))
(define (read-symbol-elements port)
(let ((c (my-read-char port)))
(cond
@@ -1226,6 +1275,7 @@
; Extension: When reading |...|, *include* the bars in the symbol, so that
; when we print it out later we know that there were bars there originally.
+ (: read-literal-symbol (input-port -> (list-of char)))
(define (read-literal-symbol port)
(let ((c (my-read-char port)))
(cond
@@ -1240,6 +1290,7 @@
; Read |...| symbol (like Common Lisp)
; This is present in R7RS draft 9.
+ (: get-barred-symbol (input-port -> symbol))
(define (get-barred-symbol port)
(my-read-char port) ; Consume the initial vertical bar.
(string->symbol (list->string
@@ -1255,6 +1306,7 @@
; procedureality (implemented here) is needed.
; This lets us implement both a curly-infix-ONLY-read
; as well as a neoteric-read, without duplicating code.
+ (: underlying-read (:reader-proc: input-port -> *))
(define (underlying-read no-indent-read port)
(consume-whitespace port)
(let* ((pos (get-sourceinfo port))
@@ -1395,6 +1447,7 @@
(else (transform-mixed-infix lyst))))
+ (: curly-infix-read-real (:reader-proc: input-port -> *))
(define (curly-infix-read-real no-indent-read port)
(let* ((pos (get-sourceinfo port))
(c (my-peek-char port)))
@@ -1543,6 +1596,7 @@
(define sublist (string->symbol "$"))
(define sublist-char #\$) ; First character of sublist symbol.
+ (: indentation>? (string string --> boolean))
(define (indentation>? indentation1 indentation2)
(let ((len1 (string-length indentation1))
(len2 (string-length indentation2)))
@@ -1562,6 +1616,7 @@
(eqv? char tab)))
; Consume 0+ spaces or tabs
+ (: hspaces (input-port -> . *)) ;; FIXME returns undefined value.
(define (hspaces port)
(cond ; Use "cond" as "when" for portability.
((char-hspace? (my-peek-char port))
@@ -1588,6 +1643,8 @@
; Do 2-item append, but report read-error if the LHS is not a proper list.
; Don't use this if the lhs *must* be a list (e.g., if we have (list x)).
+ ;; XXX do we absolutely NEED this? Looks rather expensive. `list?`
+ ;; XXX should IMHO be avoided if all possible.
(define (my-append lhs rhs)
(cond
((eq? lhs empty-value) rhs)
@@ -1600,6 +1657,7 @@
; else returns ('normal n-expr).
; Note: If a *value* begins with #, process any potential neoteric tail,
; so weird constructs beginning with "#" like #f() will still work.
+ (: n-expr-or-scomment (input-port -> :reader-token:))
(define (n-expr-or-scomment port)
(if (eqv? (my-peek-char port) #\#)
(let* ((consumed-sharp (my-read-char port))
@@ -1619,6 +1677,7 @@
; Markers only have special meaning if their first character is
; the "normal" character, e.g., {$} is not a sublist.
; Call "process-sharp" if first char is "#".
+ (: n-expr (input-port -> :reader-token:))
(define (n-expr port)
(let ((c (my-peek-char port)))
(let-splitter (results type expr)
@@ -1648,6 +1707,7 @@
; We do NOT consume the peeked char (so EOL can be examined later).
; Note that this calls the neoteric-read procedure directly, because
; quoted markers are no longer markers. E.G., '$ is just (quote $).
+ (: maybe-initial-abbrev (input-port * -> :reader-token:))
(define (maybe-initial-abbrev port abbrev-procedure)
(let ((c (my-peek-char port)))
(if (or (char-hspace? c) (eqv? c carriage-return) (eqv? c linefeed))
@@ -1657,6 +1717,7 @@
; Read the first n-expr on a line; handle abbrev+whitespace specially.
; Returns ('normal VALUE) in most cases.
+ (: n-expr-first (input-port -> :reader-token:))
(define (n-expr-first port)
(case (my-peek-char port)
((#\')
@@ -1686,6 +1747,7 @@
; Consume ;-comment (if there), consume EOL, and return new indent.
; Skip ;-comment-only lines; a following indent-only line is empty.
+ (: get-next-indent (input-port -> string))
(define (get-next-indent port)
(consume-to-eol port)
(consume-end-of-line port)
@@ -1701,6 +1763,7 @@
(else (list->string indentation-as-list)))))
; Implement (scomment hs | datum-commentw hs n-expr hs)
+ (: skippable (symbol input-port -> . *)) ; FIXME: incomplete result type
(define (skippable stopper port)
(cond
((eq? stopper 'scomment)
@@ -1751,6 +1814,7 @@
; Return contents (value) of collecting-content. It does *not* report a
; stopper or ending indent, because it is *ONLY* stopped by collecting-end
+ (: collecting-content (input-port -> *)) ; ??? doesn't it return :reader-token: ???
(define (collecting-content port)
(let* ((c (my-peek-char port)))
(cond
@@ -1789,6 +1853,7 @@
; Skip scomments and error out if we have a normal n-expr, implementing:
; skippable* (n-expr error)?
+ (: n-expr-error (input-port pair -> :reader-token:))
(define (n-expr-error port full)
(if (not (eq? (car full) 'normal))
(read-error "BUG! n-expr-error called but stopper not normal"))
@@ -1806,6 +1871,7 @@
(list n-stopper (cadr full)))))))
; Returns (stopper value-after-period)
+ (: post-period (input-port -> :reader-token:))
(define (post-period port)
(if (not (lcomment-eol? (my-peek-char port)))
(let-splitter (pn-full-results pn-stopper pn-value)
@@ -1831,6 +1897,7 @@
; Returns (stopper computed-value).
; The stopper may be 'normal, 'scomment (special comment),
; 'abbrevw (initial abbreviation), 'sublist-marker, or 'group-split-marker
+ (: line-exprs (input-port -> :reader-token:))
(define (line-exprs port)
(let-splitter (basic-full-results basic-special basic-value)
(n-expr-first port)
@@ -1865,6 +1932,7 @@
; Returns (stopper computed-value); stopper may be 'normal, etc.
; Read in one n-expr, then process based on whether or not it's special.
+ (: rest-of-line (input-port -> :reader-token:))
(define (rest-of-line port)
(let-splitter (basic-full-results basic-special basic-value)
(n-expr port)
@@ -1901,6 +1969,7 @@
(else (list 'normal (list basic-value))))))
; Returns (new-indent computed-value)
+ (: body (input-port string -> :reader-token:))
(define (body port starting-indent)
(let-splitter (i-full-results i-new-indent i-value)
(it-expr port starting-indent)
@@ -1919,6 +1988,7 @@
(list i-new-indent (list1e i-value))))) ; dedent - end list.
; Returns (new-indent computed-value)
+ (: it-expr-real (input-port string -> :reader-indent-token:))
(define (it-expr-real port starting-indent)
(let-splitter (line-full-results line-stopper line-value)
(line-exprs port)
@@ -2009,6 +2079,7 @@
; Read it-expr. This is a wrapper that attaches source info
; and checks for consistent indentation results.
+ (: it-expr (input-port string -> :reader-indent-token:))
(define (it-expr port starting-indent)
(let ((pos (get-sourceinfo port)))
(let-splitter (results results-indent results-value)
@@ -2017,6 +2088,7 @@
(read-error "Inconsistent indentation"))
(list results-indent (attach-sourceinfo pos results-value)))))
+ (: initial-indent-expr-tail :reader-proc:)
(define (initial-indent-expr-tail port)
(if (not (memv (my-peek-char port) initial-comment-eol))
(let-splitter (results results-stopper results-value)
@@ -2033,6 +2105,7 @@
; Top level - read a sweet-expression (t-expression). Handle special
; cases, such as initial indent; call it-expr for normal case.
+ (: t-expr-real :reader-proc:)
(define (t-expr-real port)
(let* ((c (my-peek-char port)))
(cond
@@ -2058,6 +2131,7 @@
results-value))))))
; Top level - read a sweet-expression (t-expression). Handle special
+ (: t-expr :reader-proc:)
(define (t-expr port)
(let* ((te (t-expr-real port)))
(if (eq? te empty-value)
@@ -2066,6 +2140,7 @@
; Skip until we find a line with 0 indent characters.
; We use this after read error to resync to good input.
+ (: read-to-unindented-line :reader-proc:)
(define (read-to-unindented-line port)
(let* ((c (my-peek-char port)))
(cond
@@ -2081,6 +2156,7 @@
; Call on sweet-expression reader - use exceptions
; so that errors will force a restart.
+ (: t-expr-catch :reader-proc:)
(define (t-expr-catch port)
(init-sweet)
------------------------------------------------------------------------------
DreamFactory - Open Source REST & JSON Services for HTML5 & Native Apps
OAuth, Users, Roles, SQL, NoSQL, BLOB Storage and External API Access
Free app hosting. Or install the open source package on any LAMP server.
Sign up and see examples for AngularJS, jQuery, Sencha Touch and Native!
http://pubads.g.doubleclick.net/gampad/clk?id=63469471&iu=/4140/ostg.clktrk
_______________________________________________
Readable-discuss mailing list
Readable-discuss@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/readable-discuss
