The bulk of it

This huge |letrec| contains a few procedures of global interest, and code for each of the interface routines described above.

|Quotify| surrounds its string argument with the separator (a character), replacing all occurences of `|||' by `|
|' and all occurences of the separator itself by `|||separator'.

|Specchars| is an association list giving the printed representation of a few special characters. It is used by |write|.

|Strange?| returns whether its argument requires quotification. Strings are always quotified, but atoms will be quotified only if they contain weird characters, are `|.|', or generally speaking would not evaluate to a symbol if re-read unquoted.

|Put-list| prints the tail of a list (the heading `|(|' is printed by the main routine). Note that this code does not check whether the list is circular.

|Delimby| is used for input and can be understood as reversing the action of a |Quotify|: it reads characters until it reaches a specified separator.

|Get-symbol| will return the next symbol from the input (unquoted: surrounded neither by `"' nor by `||')

|Get-number| and |Get-number-prefixed| help reading a number prefixed by `|#|': |Get-number| is called before the `|#|' occured, but when we already know we're dealing with a number. |Get-number-prefixed| is called when the sharp has been read, and we want to interpret the following character. In this version, inexact and exact numbers are handled likewise.

(letrec ((quotify (lambda (string separator) (define (s l) (cond ((null? l) (list separator)) ((or (equal? (car l) separator) (equal? (car l) #
)) (cons #
(cons (car l) (s (cdr l))))) (else (cons (car l) (s (cdr l)))))) (list->string (cons separator (s (string->list string)))))) (specchars '((# . "#
SPACE") (#. "#
ESCAPE") (#. "#
TAB") (#
. "#
NEWLINE") (#. "#
PAGE") (#. "#
RETURN"))) (strange? (lambda (s) (or (string->number s) (string-null? s) (equal? s ".") (equal? (substring (string-append s " ") 0 2) "#
") (do ((l (string->list s) (cdr l))) ((or (null? l) (not (char=? (car l) (char-upcase (car l)))) (member (car l) (list* #|| #  ##́  ##̈ ## ##̀
(map car specchars)))) (not (null? l))))))) (put-list (lambda (l printer output) (cond ((null? l) (((atom? l) ((printer l output) ((else (printer (car l) output) (if (pair? (cdr l)) ((put-list (cdr l) printer output)))))

(get-char (lambda (input) (let ((ch (@read-char input))) (cond ((char-whitespace? ch) (get-char input)) ((equal? ch # ) (begin (@read-line input) (get-char input))) (else ch))))) (delimby (lambda (ch input) (let ((in (@read-char input))) (cond ((@eof-object? in) (error "Unmatched " ch)) ((equal? in #
) (let ((next (@read-char input))) (if (@eof-object? next) (error "Escaped void") (cons next (delimby ch input))))) ((equal? ch in) ()) (else (cons in (delimby ch input))))))) (list->symbol (lambda (l) (string->symbol (list->string l)))) (get-symbol (lambda (input) (let ((first (@read-char input))) (cond ((@eof-object? first) '()) ((char-whitespace? first) '()) ((member first '(## ##́#̀  #  ##̈|| #

#

#{ #})) (@unread-char input) '()) (else (cons (char-upcase first) (get-symbol input))))))) (get-number (lambda (base input) (let ((first (@read-char input))) (if (equal? first ##) (get-number-prefixed base input) (let* ((atom (list->string (cons first (get-symbol input)))) (number (string->number atom base))) (if (number? number) number (error "Number expected" atom))))))) (get-number-prefixed (lambda (base input) (let ((next (char-upcase (@read-char input)))) (case next ((#) (get-number 2 input)) ((#Ø) (get-number 8 input)) ((#) (get-number 10 input)) ((#) (get-number 16 input)) ((##) (get-number base input)) (else (error "Illegal use of #" next)))))) ) (set! @write (lambda (datum . port) (let ((output (cond ((null? port) (current-output-port)) ((port? (car port)) (car port)) (else (error "Port expected" output))))) (cond ((number? datum) (((pair? datum) ((put-list datum @write output)) ((null? datum) (((string? datum) (((symbol? datum) (let ((datum (symbol->string datum))) ((quotify datum #||) datum) output))) ((char? datum) (if (assoc datum specchars) ((((vector? datum) ((do ((i 0 (1+ i))) ((= i (vector-length datum)) ((@write (vector-ref datum i) output) (if (< i (-1+ (vector-length datum))) () *the-non-printing-object*))) (set! @display (lambda (datum . port) (let ((output (if (null? port) (current-output-port) (car port)))) (cond ((number? datum) (((pair? datum) ((put-list datum @display output)) ((null? datum) (((string? datum) (((symbol? datum) (((char? datum) (((vector? datum) ((do ((i 0 (1+ i))) ((= i (vector-length datum)) ((@display (vector-ref datum i)) (if (< i (-1+ (vector-length datum))) () *the-non-printing-object*))) (set! @newline (lambda port (let ((output (if (null? port) (current-output-port) (car port)))) (*the-non-printing-object*))) (set! @write-char (lambda (char . port) (let ((output (if (null? port) (current-output-port) (car port)))) (if (char? char) (@write char output) (error '@WRITE-CHAR "Argument must be char" char)) *the-non-printing-object*)))

(set! @read read) (set! @read-atom (lambda port (let* ((input (if (null? port) (current-input-port) (car port))) (first (get-char input))) (case first ((#

#

#{ #} ## ##́)̀ (list (list->symbol (list first)))) ((#)̈ (list->string (delimby first input))) ((#||) (list->symbol (delimby first input))) ((# ) (list (list->symbol (cons first (if (member (@peek-char input) '(# #)̇) (list (@read-char input)) ()))))) ((##) (let ((next (char-upcase (@read-char input)))) (case next ((#) #T) ((#) #F) ((# )'(|#(|))((#
)(let*((third (char - upcase(@read - charinput)))(atom(list - > string(list*firstnextthird (get - symbolinput))))(char(assocatom(map(lambda(l )(cons(cdrl )(carl )))specchars))))(if (null?char)(if (= (string - lengthatom)3)third (error"Illegalcharacterconstant"atom))(cdrchar))))((#)(list - > symbol (list*firstnext(get - symbolinput))))(else(@unread - charinput)(get - number - prefixed10input)))))(else(if (@eof - object?first)first(let*((atom(list - > string(cons(char - upcasefirst)(get - symbolinput))))(number(string - > numberatom)))(cond ((number?number)number)((equal?atom".")'(|.|))(else(string - > symbolatom))))))))))(set!@eof - object?eof - object?)(set!@char - ready?char - ready?)(set!@peek - charpeek - char)(set!@read - charread - char)(set!@read - line(lambdaport(let((input(if (null?port)(current - input - port)(carport))))(do((l'()(conscharl ))(char(@read - charinput)(@read - charinput)))((or(equal?char#$\NEWLINE$)(equal?char#$\RETURN$)(@eof - object?char))(if (and (null?l )(@eof - object?char))char(list - > string(reverse!l ))))))))(set!@unread - charunread - char))