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 (define char-table ; first nonprintable chars
'#("nul" "soh" "stx" "etx" "eot" "enq" "ack" "bel" "bs" "tab" "newline" '#("nul" "soh" "stx" "etx" "eot" "enq" "ack" "bel" "bs" "tab" "newline"
"vt" "ff" "return" "so" "si" "dle" "dc1" "dc2" "dc3" "dc4" "nak" "vt" "ff" "return" "so" "si" "dle" "dc1" "dc2" "dc3" "dc4" "nak"
@ -124,7 +124,7 @@
(string=? str "..."))])))) (string=? str "..."))]))))
(or (normal-symbol-string? str) (or (normal-symbol-string? str)
(peculiar-symbol-string? str)))) (peculiar-symbol-string? str))))
(define write-symbol-esc-loop (define write-symbol-esc-loop
(lambda (x i n p) (lambda (x i n p)
(unless ($fx= i n) (unless ($fx= i n)
@ -349,9 +349,9 @@
[else [else
(write-char* "#<unknown>" p) (write-char* "#<unknown>" p)
i]))) i])))
(define print-graph (make-parameter #f)) (define print-graph (make-parameter #f))
(define (hasher x h) (define (hasher x h)
(define (vec-graph x i j h) (define (vec-graph x i j h)
(unless (fx= i j) (unless (fx= i j)
@ -413,14 +413,14 @@
(if (print-graph) (if (print-graph)
(graph x h) (graph x h)
(dynamic x h))) (dynamic x h)))
(define (write x p) (define (write-to-port x p)
(let ([h (make-hash-table)]) (let ([h (make-hash-table)])
(hasher x h) (hasher x h)
(writer x p #t h 0)) (writer x p #t h 0))
(flush-output-port p)) (flush-output-port p))
;;; ;;;
(define (display x p) (define (display-to-port x p)
(let ([h (make-hash-table)]) (let ([h (make-hash-table)])
(hasher x h) (hasher x h)
(writer x p #f h 0)) (writer x p #f h 0))
@ -447,12 +447,12 @@
[($char= c #\a) [($char= c #\a)
(when (null? args) (when (null? args)
(error who "insufficient arguments")) (error who "insufficient arguments"))
(display (car args) p) (display-to-port (car args) p)
(f (fxadd1 i) (cdr args))] (f (fxadd1 i) (cdr args))]
[($char= c #\s) [($char= c #\s)
(when (null? args) (when (null? args)
(error who "insufficient arguments")) (error who "insufficient arguments"))
(write (car args) p) (write-to-port (car args) p)
(f (fxadd1 i) (cdr args))] (f (fxadd1 i) (cdr args))]
[else [else
(error who "invalid sequence ~~~a" c)])))] (error who "invalid sequence ~~~a" c)])))]
@ -460,7 +460,7 @@
(write-char c p) (write-char c p)
(f (fxadd1 i) args)])))) (f (fxadd1 i) args)]))))
(flush-output-port p))) (flush-output-port p)))
(define fprintf (define fprintf
(lambda (port fmt . args) (lambda (port fmt . args)
(unless (output-port? port) (unless (output-port? port)
@ -468,21 +468,8 @@
(unless (string? fmt) (unless (string? fmt)
(error 'fprintf "~s is not a string" fmt)) (error 'fprintf "~s is not a string" fmt))
(formatter 'fprintf port fmt args))) (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 (define display-error
(lambda (errname who fmt args) (lambda (errname who fmt args)
(unless (string? fmt) (unless (string? fmt)
@ -494,27 +481,37 @@
(formatter 'print-error p fmt args) (formatter 'print-error p fmt args)
(write-char #\. p) (write-char #\. p)
(newline p)))) (newline p))))
;;; ;;;
(primitive-set! 'format format) (primitive-set! 'format
(primitive-set! 'printf printf) (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! 'fprintf fprintf)
(primitive-set! 'print-graph print-graph) (primitive-set! 'print-graph print-graph)
(primitive-set! 'write (primitive-set! 'write
(case-lambda (case-lambda
[(x) (write x (current-output-port))] [(x) (write-to-port x (current-output-port))]
[(x p) [(x p)
(unless (output-port? p) (unless (output-port? p)
(error 'write "~s is not an output port" p)) (error 'write "~s is not an output port" p))
(write x p)])) (write-to-port x p)]))
(primitive-set! 'display (primitive-set! 'display
(case-lambda (case-lambda
[(x) (display x (current-output-port))] [(x) (display-to-port x (current-output-port))]
[(x p) [(x p)
(unless (output-port? p) (unless (output-port? p)
(error 'display "~s is not an output port" p)) (error 'display "~s is not an output port" p))
(display x p)])) (display-to-port x p)]))
(primitive-set! 'print-error (primitive-set! 'print-error
(lambda (who fmt . args) (lambda (who fmt . args)
(display-error "Error" 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] ["libcore.ss" "libcore.fasl" p0 onepass]
["libchezio.ss" "libchezio.fasl" p0 onepass] ["libchezio.ss" "libchezio.fasl" p0 onepass]
["libhash.ss" "libhash.fasl" p0 onepass] ["libhash.ss" "libhash.fasl" p0 onepass]
["libwriter.ss" "libwriter.fasl" p0 onepass] ["libwriter.ss" "libwriter.fasl" p0 onepass]
["libtokenizer.ss" "libtokenizer.fasl" p0 onepass] ["libtokenizer.ss" "libtokenizer.fasl" p0 onepass]
["libassembler.ss" "libassembler.fasl" p0 onepass] ["libassembler.ss" "libassembler.fasl" p0 onepass]
["libintelasm.ss" "libintelasm.fasl" p0 onepass] ["libintelasm.ss" "libintelasm.fasl" p0 onepass]
["libfasl.ss" "libfasl.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?)] [null? null?-label (core-prim . null?)]
[procedure? procedure?-label (core-prim . procedure?)] [procedure? procedure?-label (core-prim . procedure?)]
[eof-object? eof-object?-label (core-prim . eof-object?)] [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)] [eof-object eof-object-label (core-prim . eof-object)]
;;; comparison ;;; comparison
[eq? eq?-label (core-prim . eq?)] [eq? eq?-label (core-prim . eq?)]
@ -562,6 +563,8 @@
[memq memq-label (core-prim . memq)] [memq memq-label (core-prim . memq)]
[memv memv-label (core-prim . memv)] [memv memv-label (core-prim . memv)]
[member member-label (core-prim . member)] [member member-label (core-prim . member)]
[$car $car-label (core-prim . $car)]
[$cdr $cdr-label (core-prim . $cdr)]
;;; chars ;;; chars
[char? char?-label (core-prim . char?)] [char? char?-label (core-prim . char?)]
[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= $char=-label (core-prim . $char=)] [$char= $char=-label (core-prim . $char=)]
[$char->fixnum $char->fixnum-label (core-prim . $char->fixnum)] [$char->fixnum $char->fixnum-label (core-prim . $char->fixnum)]
[$fixnum->char $fixnum->char-label (core-prim . $fixnum->char)]
;;; strings ;;; strings
[string? string?-label (core-prim . string?)] [string? string?-label (core-prim . string?)]
[make-string make-string-label (core-prim . make-string)] [make-string make-string-label (core-prim . make-string)]
@ -581,6 +585,9 @@
[string=? string=?-label (core-prim . string=?)] [string=? string=?-label (core-prim . string=?)]
[substring substring-label (core-prim . substring)] [substring substring-label (core-prim . substring)]
[list->string list->string-label (core-prim . list->string)] [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 ;;; vectors
[vector vector-label (core-prim . vector)] [vector vector-label (core-prim . vector)]
[make-vector make-vector-label (core-prim . make-vector)] [make-vector make-vector-label (core-prim . make-vector)]
@ -615,7 +622,11 @@
[fxlogand fxlogand-label (core-prim . fxlogand)] [fxlogand fxlogand-label (core-prim . fxlogand)]
[fxlogor fxlogor-label (core-prim . fxlogor)] [fxlogor fxlogor-label (core-prim . fxlogor)]
[fxlognot fxlognot-label (core-prim . fxlognot)] [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-)]
[$fx< $fx<-label (core-prim . $fx<)] [$fx< $fx<-label (core-prim . $fx<)]
;;; flonum ;;; flonum
[string->flonum string->flonum-label (core-prim . string->flonum)] [string->flonum string->flonum-label (core-prim . string->flonum)]
@ -623,7 +634,9 @@
[- minus-label (core-prim . -)] [- minus-label (core-prim . -)]
[* *-label (core-prim . *)] [* *-label (core-prim . *)]
[+ plus-label (core-prim . +)] [+ plus-label (core-prim . +)]
[number? number?-label (core-prim . number?)]
[quotient quotient-label (core-prim . quotient)] [quotient quotient-label (core-prim . quotient)]
[number->string number->string-label (core-prim . number->string)]
;;; symbols/gensyms ;;; symbols/gensyms
[symbol? symbol?-label (core-prim . symbol?)] [symbol? symbol?-label (core-prim . symbol?)]
[gensym? gensym?-label (core-prim . gensym?)] [gensym? gensym?-label (core-prim . gensym?)]
@ -641,12 +654,20 @@
;;; IO/ports ;;; IO/ports
[output-port? output-port?-label (core-prim . output-port?)] [output-port? output-port?-label (core-prim . output-port?)]
[input-port? input-port?-label (core-prim . input-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-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)] [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-input-port console-input-port-label (core-prim . console-input-port)]
[console-output-port console-output-port-label (core-prim . console-output-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-input-port current-input-port-label (core-prim . current-input-port)]
[current-output-port current-output-port-label (core-prim . current-output-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)] [flush-output-port flush-output-port-label (core-prim . flush-output-port)]
[reset-input-port! reset-input-port!-label (core-prim . reset-input-port!)] [reset-input-port! reset-input-port!-label (core-prim . reset-input-port!)]
;;; IO/high-level ;;; IO/high-level
@ -663,8 +684,10 @@
[format format-label (core-prim . format)] [format format-label (core-prim . format)]
[pretty-print pretty-print-label (core-prim . pretty-print)] [pretty-print pretty-print-label (core-prim . pretty-print)]
[comment-handler comment-handler-label (core-prim . comment-handler)] [comment-handler comment-handler-label (core-prim . comment-handler)]
[print-gensym print-gensym-label (core-prim . print-gensym)]
;;; hash tables ;;; hash tables
[make-hash-table make-hash-table-label (core-prim . make-hash-table)] [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)] [get-hash-table get-hash-table-label (core-prim . get-hash-table)]
[put-hash-table! put-hash-table!-label (core-prim . put-hash-table!)] [put-hash-table! put-hash-table!-label (core-prim . put-hash-table!)]
;;; evaluation / control ;;; evaluation / control
@ -692,6 +715,10 @@
[record-type-field-names record-type-field-names-label (core-prim . record-type-field-names)] [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-symbol record-type-symbol-label (core-prim . record-type-symbol)]
[record-type-name record-type-name-label (core-prim . record-type-name)] [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-accessor record-field-accessor-label (core-prim . record-field-accessor)]
[record-field-mutator record-field-mutator-label (core-prim . record-field-mutator)] [record-field-mutator record-field-mutator-label (core-prim . record-field-mutator)]
;;; records/low-level ;;; records/low-level
@ -719,6 +746,8 @@
[immediate? immediate?-label (core-prim . immediate?)] [immediate? immediate?-label (core-prim . immediate?)]
[primitive-set! primitive-set!-label (core-prim . primitive-set!)] [primitive-set! primitive-set!-label (core-prim . primitive-set!)]
[primitive-ref primitive-ref-label (core-prim . primitive-ref)] [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 (define make-scheme-rib
(lambda () (lambda ()