conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

* libwriter librarified

This commit is contained in:
Abdulaziz Ghuloum 2007-04-29 23:00:20 -04:00
parent 5d7afb92d4
commit 97478fd873
4 changed files with 63 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
src/ikarus.boot
View File

Binary file not shown.

67
src/libwriter.ss
View File

@ -1,9 +1,9 @@
;;; 6.2: * added a printer for bwp-objects
;;; WRITER provides display and write.
(library (ikarus writer)
(export)
(import (scheme))
(let ()
(define char-table ; first nonprintable chars
'#("nul" "soh" "stx" "etx" "eot" "enq" "ack" "bel" "bs" "tab" "newline"
"vt" "ff" "return" "so" "si" "dle" "dc1" "dc2" "dc3" "dc4" "nak"
@ -124,7 +124,7 @@
(string=? str "..."))]))))
(or (normal-symbol-string? str)
(peculiar-symbol-string? str))))
(define write-symbol-esc-loop
(lambda (x i n p)
(unless ($fx= i n)
@ -349,9 +349,9 @@
[else
(write-char* "#<unknown>" p)
i])))
(define print-graph (make-parameter #f))
(define (hasher x h)
(define (vec-graph x i j h)
(unless (fx= i j)
@ -413,14 +413,14 @@
(if (print-graph)
(graph x h)
(dynamic x h)))
(define (write x p)
(define (write-to-port x p)
(let ([h (make-hash-table)])
(hasher x h)
(writer x p #t h 0))
(flush-output-port p))
;;;
(define (display x p)
(define (display-to-port x p)
(let ([h (make-hash-table)])
(hasher x h)
(writer x p #f h 0))
@ -447,12 +447,12 @@
[($char= c #\a)
(when (null? args)
(error who "insufficient arguments"))
(display (car args) p)
(display-to-port (car args) p)
(f (fxadd1 i) (cdr args))]
[($char= c #\s)
(when (null? args)
(error who "insufficient arguments"))
(write (car args) p)
(write-to-port (car args) p)
(f (fxadd1 i) (cdr args))]
[else
(error who "invalid sequence ~~~a" c)])))]
@ -460,7 +460,7 @@
(write-char c p)
(f (fxadd1 i) args)]))))
(flush-output-port p)))
(define fprintf
(lambda (port fmt . args)
(unless (output-port? port)
@ -468,21 +468,8 @@
(unless (string? fmt)
(error 'fprintf "~s is not a string" fmt))
(formatter 'fprintf port fmt args)))
(define printf
(lambda (fmt . args)
(unless (string? fmt)
(error 'printf "~s is not a string" fmt))
(formatter 'printf (current-output-port) fmt args)))
(define format
(lambda (fmt . args)
(unless (string? fmt)
(error 'format "~s is not a string" fmt))
(let ([p (open-output-string)])
(formatter 'format p fmt args)
(get-output-string p))))
(define display-error
(lambda (errname who fmt args)
(unless (string? fmt)
@ -494,27 +481,37 @@
(formatter 'print-error p fmt args)
(write-char #\. p)
(newline p))))
;;;
(primitive-set! 'format format)
(primitive-set! 'printf printf)
(primitive-set! 'format
(lambda (fmt . args)
(unless (string? fmt)
(error 'format "~s is not a string" fmt))
(let ([p (open-output-string)])
(formatter 'format p fmt args)
(get-output-string p))))
(primitive-set! 'printf
(lambda (fmt . args)
(unless (string? fmt)
(error 'printf "~s is not a string" fmt))
(formatter 'printf (current-output-port) fmt args)))
(primitive-set! 'fprintf fprintf)
(primitive-set! 'print-graph print-graph)
(primitive-set! 'write
(case-lambda
[(x) (write x (current-output-port))]
[(x) (write-to-port x (current-output-port))]
[(x p)
(unless (output-port? p)
(error 'write "~s is not an output port" p))
(write x p)]))
(write-to-port x p)]))
(primitive-set! 'display
(case-lambda
[(x) (display x (current-output-port))]
[(x) (display-to-port x (current-output-port))]
[(x p)
(unless (output-port? p)
(error 'display "~s is not an output port" p))
(display x p)]))
(display-to-port x p)]))
(primitive-set! 'print-error
(lambda (who fmt . args)
(display-error "Error" who fmt args)))

4
src/makefile.ss
View File

@ -239,8 +239,8 @@
["libcore.ss" "libcore.fasl" p0 onepass]
["libchezio.ss" "libchezio.fasl" p0 onepass]
["libhash.ss" "libhash.fasl" p0 onepass]
["libwriter.ss" "libwriter.fasl" p0 onepass]
["libtokenizer.ss" "libtokenizer.fasl" p0 onepass]
["libwriter.ss" "libwriter.fasl" p0 onepass]
["libtokenizer.ss" "libtokenizer.fasl" p0 onepass]
["libassembler.ss" "libassembler.fasl" p0 onepass]
["libintelasm.ss" "libintelasm.fasl" p0 onepass]
["libfasl.ss" "libfasl.fasl" p0 onepass]

29
src/syntax.ss
View File

@ -533,6 +533,7 @@
[null? null?-label (core-prim . null?)]
[procedure? procedure?-label (core-prim . procedure?)]
[eof-object? eof-object?-label (core-prim . eof-object?)]
[bwp-object? bwp-object?-label (core-prim . bwp-object?)]
[eof-object eof-object-label (core-prim . eof-object)]
;;; comparison
[eq? eq?-label (core-prim . eq?)]
@ -562,6 +563,8 @@
[memq memq-label (core-prim . memq)]
[memv memv-label (core-prim . memv)]
[member member-label (core-prim . member)]
[$car $car-label (core-prim . $car)]
[$cdr $cdr-label (core-prim . $cdr)]
;;; chars
[char? char?-label (core-prim . char?)]
[char=? char=?-label (core-prim . char=?)]
@ -572,6 +575,7 @@
[$char<= $char<=-label (core-prim . $char<=)]
[$char= $char=-label (core-prim . $char=)]
[$char->fixnum $char->fixnum-label (core-prim . $char->fixnum)]
[$fixnum->char $fixnum->char-label (core-prim . $fixnum->char)]
;;; strings
[string? string?-label (core-prim . string?)]
[make-string make-string-label (core-prim . make-string)]
@ -581,6 +585,9 @@
[string=? string=?-label (core-prim . string=?)]
[substring substring-label (core-prim . substring)]
[list->string list->string-label (core-prim . list->string)]
[$string-ref $string-ref-label (core-prim . $string-ref)]
[$string-set! $string-set!-label (core-prim . $string-set!)]
[$string-length $string-length-label (core-prim . $string-length)]
;;; vectors
[vector vector-label (core-prim . vector)]
[make-vector make-vector-label (core-prim . make-vector)]
@ -615,7 +622,11 @@
[fxlogand fxlogand-label (core-prim . fxlogand)]
[fxlogor fxlogor-label (core-prim . fxlogor)]
[fxlognot fxlognot-label (core-prim . fxlognot)]
[$fxadd1 $fxadd1-label (core-prim . $fxadd1)]
[$fx>= $fx>=-label (core-prim . $fx>=)]
[$fx= $fx=-label (core-prim . $fx=)]
[$fx+ $fx+-label (core-prim . $fx+)]
[$fx- $fx--label (core-prim . $fx-)]
[$fx< $fx<-label (core-prim . $fx<)]
;;; flonum
[string->flonum string->flonum-label (core-prim . string->flonum)]
@ -623,7 +634,9 @@
[- minus-label (core-prim . -)]
[* *-label (core-prim . *)]
[+ plus-label (core-prim . +)]
[number? number?-label (core-prim . number?)]
[quotient quotient-label (core-prim . quotient)]
[number->string number->string-label (core-prim . number->string)]
;;; symbols/gensyms
[symbol? symbol?-label (core-prim . symbol?)]
[gensym? gensym?-label (core-prim . gensym?)]
@ -641,12 +654,20 @@
;;; IO/ports
[output-port? output-port?-label (core-prim . output-port?)]
[input-port? input-port?-label (core-prim . input-port?)]
[input-port-name input-port-name-label (core-prim . input-port-name)]
[output-port-name output-port-name-label (core-prim . output-port-name)]
[open-input-file open-input-file-label (core-prim . open-input-file)]
[open-output-file open-output-file-label (core-prim . open-output-file)]
[open-output-string open-output-string-label (core-prim . open-output-string)]
[get-output-string get-output-string-label (core-prim . get-output-string)]
[close-input-port close-input-port-label (core-prim . close-input-port)]
[console-input-port console-input-port-label (core-prim . console-input-port)]
[console-output-port console-output-port-label (core-prim . console-output-port)]
[current-input-port current-input-port-label (core-prim . current-input-port)]
[current-output-port current-output-port-label (core-prim . current-output-port)]
[standard-input-port standard-input-port-label (core-prim . standard-input-port)]
[standard-output-port standard-output-port-label (core-prim . standard-output-port)]
[standard-error-port standard-error-port-label (core-prim . standard-error-port)]
[flush-output-port flush-output-port-label (core-prim . flush-output-port)]
[reset-input-port! reset-input-port!-label (core-prim . reset-input-port!)]
;;; IO/high-level
@ -663,8 +684,10 @@
[format format-label (core-prim . format)]
[pretty-print pretty-print-label (core-prim . pretty-print)]
[comment-handler comment-handler-label (core-prim . comment-handler)]
[print-gensym print-gensym-label (core-prim . print-gensym)]
;;; hash tables
[make-hash-table make-hash-table-label (core-prim . make-hash-table)]
[hash-table? hash-table?-label (core-prim . hash-table?)]
[get-hash-table get-hash-table-label (core-prim . get-hash-table)]
[put-hash-table! put-hash-table!-label (core-prim . put-hash-table!)]
;;; evaluation / control
@ -692,6 +715,10 @@
[record-type-field-names record-type-field-names-label (core-prim . record-type-field-names)]
[record-type-symbol record-type-symbol-label (core-prim . record-type-symbol)]
[record-type-name record-type-name-label (core-prim . record-type-name)]
[record-name record-name-label (core-prim . record-name)]
[record-length record-length-label (core-prim . record-length)]
[record-printer record-printer-label (core-prim . record-printer)]
[record-ref record-ref-label (core-prim . record-ref)]
[record-field-accessor record-field-accessor-label (core-prim . record-field-accessor)]
[record-field-mutator record-field-mutator-label (core-prim . record-field-mutator)]
;;; records/low-level
@ -719,6 +746,8 @@
[immediate? immediate?-label (core-prim . immediate?)]
[primitive-set! primitive-set!-label (core-prim . primitive-set!)]
[primitive-ref primitive-ref-label (core-prim . primitive-ref)]
[$forward-ptr? $forward-ptr?-label (core-prim . $forward-ptr?)]
[$unbound-object? $unbound-object?-label (core-prim . $unbound-object?)]
))
(define make-scheme-rib
(lambda ()