application/octet-stream
•
4.08 KB
•
98 lines
[defn write/raw/array [v port hr?]
[port 'block-write "##["]
[dotimes [i [array/length v]]
[write/raw [array/ref v i] port hr?]
[when [< i [- [array/length v] 1]]
[port 'block-write " "]]]
[port 'block-write "]"]]
[defn write/raw/buffer [v port hr?]
[if hr?
[port 'block-write [fmt "#<buffer :id {} :size {:x}>" [val->id v] [buffer/length v]]]
[do [port 'block-write "#m"]
[def view [buffer/u8* v]]
[dotimes [i [buffer/length v]]
[port 'block-write [fmt "{:02X}" [buffer/ref view i]]]]]]]
[defn write/raw/bytecode-array [v port hr?]
[port 'block-write "#{"]
[write/raw/array [bytecode-literals v] port #f]
[dotimes [i [bytecode-array/length v]]
[when [zero? [bit-and i #x1F]]
[port 'block-write "\n"]]
[port 'block-write [fmt "{:02X}" [bytecode-op->int [bytecode-array/ref v i]]]]]
[port 'block-write "\n}"]]
[defn write/raw/tree/rec [v port hr? always-space?]
[when [or [not v]
[not [tree/key* v]]]
[return always-space?]]
[when [write/raw/tree/rec [tree/left* v] port hr? always-space?]
[port 'block-write " "]]
[port 'block-write [keyword->string [tree/key* v]]]
[port 'block-write ": "]
[write/raw [tree/value* v] port hr?]
[write/raw/tree/rec [tree/right* v] port hr? #t]]
[defn write/raw/tree [v port hr?]
[port 'block-write "#@["]
[write/raw/tree/rec v port hr? #f]
[port 'block-write "]"]]
[defn write/raw/pair [v port hr?]
[when [and [== 'quote [car v]]
[nil? [cddr v]]]
[port 'block-write "'"]
[return [write/raw [cadr v] port hr?]]]
[port 'block-write "["]
[def first? #f]
[while v
[if first?
[port 'block-write " "]
[set! first? #t]]
[if [pair? v]
[write/raw [car v] port hr?]
[do [port 'block-write ". "]
[write/raw v port hr?]]]
[cdr! v]]
[port 'block-write "]"]]
[defn write/raw [v port hr?]
[case [type-of v]
[:nil [port 'block-write "#nil"]]
[:bool [port 'block-write [if v "#t" "#f"]]]
[:object [port 'block-write [fmt "#<environment {}>" [val->id v]]]]
[:file-handle [port 'block-write [fmt "#<file-handle {}>" [val->id v]]]]
[:buffer-view [port 'block-write [fmt "#<buffer-view {}>" [val->id v]]]]
[[:lambda :macro] [port 'block-write [symbol->string [or [closure/name v] 'anonymous]]]]
[:int [port 'block-write [int->string/decimal v]]]
[:float [port 'block-write [string v]]] ;; This one is kinda cheating
[:string [port 'block-write [if hr? v [string/write/c v]]]] ;; This one is actually cheating
[:keyword [port 'block-write [fmt ":{}" [keyword->string v]]]]
[:symbol [port 'block-write [symbol->string v]]]
[:bytecode-op [port 'block-write [fmt "#${:X}" [bytecode-op->int v]]]]
[:array [write/raw/array v port hr?]]
[:buffer [write/raw/buffer v port hr?]]
[:bytecode-array [write/raw/bytecode-array v port hr?]]
[:tree [write/raw/tree v port hr?]]
[:pair [write/raw/pair v port hr?]]
[otherwise [exception :type-error "Don't know how to write that" v]]]]
[defn write [v port]
[write/raw v [or port stdout] #f]]
[defn display/new [v port]
[write/raw v [or port stdout] #t]]
[defn string/write [v]
[case [type-of v]
[:pair [return [string/write/c v]]]]
[def p [make-string-output-port]]
[write/raw v p #f]
[p :return-string]]
[defn string/write/test [v]
[def old [string/write/c v]]
[def new [string/write v]]
[pfmtln "{old}\n---\n{new}\n -> {}" [if [== old new] [ansi-green "#t"] [ansi-red "#f"]]]
#nil]
