Fetching contributors…
Cannot retrieve contributors at this time
462 lines (386 sloc) 13.5 KB
; Copyright 2010 Brian Taylor
; Licensed under the Apache License, Version 2.0 (the "License");
; you may not use this file except in compliance with the License.
; You may obtain a copy of the License at
; Unless required by applicable law or agreed to in writing, software
; distributed under the License is distributed on an "AS IS" BASIS,
; See the License for the specific language governing permissions and
; limitations under the License.
; This loads the tiny-clos library created by some very bright
; people at XEROX Parc.
; Interestingly, this implementation supports a meta-object-protocol
; just like real clos. It's dog slow, but it works!
(require 'math)
(require "clos/clos.sch")
(define <standard-class> (make <class>
'direct-supers (list <class>)
'direct-slots nil
'class-name '<standard-class>))
(define <standard-object> (make <class>
'direct-supers (list <object>)
'direct-slots nil
'class-name '<standard-object>))
(define (initialize-slots object initargs)
"initialize slots by keyword slot names"
(let ((not-there (list 'shes-not-there)))
(dolist (slot (class-slots (class-of object)))
(let* ((name (car slot))
(value (getl initargs name not-there)))
(if (eq? value not-there)
(slot-set! object name value))))))
(define-method (initialize (obj <standard-object>) args)
(initialize-slots obj args))
(define-syntax (define-class name supers documentation slots)
"creates a new class of type <standard-class> with slots initialized using keyword args and user defined supers (or <object>)"
(define ,name (make <standard-class>
'direct-supers ,(if supers
`(list . ,supers)
`(list <standard-object>))
'direct-slots (list . ,slots)
'class-name ',name))))
(define-class <output-stream> ()
"Most basic output stream abstraction.")
(define-generic write-stream
"write something to a stream that accepts it")
;; handle null terminated strings by converting them to
;; characters and calling write-stream with that
(define-method (write-stream (stream <output-stream>)
(str <string>))
(let loop ((idx 0))
(let ((char (string-ref str idx)))
(unless (= (char->integer char) 0)
(write-stream stream char)
(loop (+ idx 1))))))
(define-class <native-output-stream> (<output-stream>)
"an output-stream that wraps a port"
;; handle character by character output
(define-method (write-stream (stream <native-output-stream>)
(char <char>))
(write-char char (slot-ref stream 'port)))
;; but this stream can handle blocks too so make that
;; go fast
(define-method (write-stream (stream <native-output-stream>)
(str <string>))
(display-string str (slot-ref stream 'port)))
(define stdout-stream (make <native-output-stream> 'port stdout))
(define stderr-stream (make <native-output-stream> 'port stderr))
(define (call-with-output-stream fname fn)
"like call-with-output-file but wraps in stream object"
(lambda (f)
(fn (make <native-output-stream> 'port f)))))
(define-syntax (with-output-stream handle-and-name . body)
(let ((handle (first handle-and-name))
(name (second handle-and-name)))
`(call-with-output-stream ,name
(lambda (,handle)
. ,body))))
;; these overrides on print-object provide all of the functionality of
;; the primitive writer but also give the user the opportunity to
;; define their own printed form for their classes.
(define-generic print-object
"defines the standard written form of an object")
;; basic catch-all
(define-method (print-object (strm <output-stream>)
(obj <object>))
(write-stream strm "#<instance-of: #")
(print-object strm (slot-ref (class-of obj)
(write-stream strm ">"))
(define-method (print-object (strm <output-stream>)
(cls <class>))
(write-stream strm #\#)
(print-object strm (slot-ref cls 'class-name)))
(define-method (print-object (strm <output-stream>)
(num <number>))
(write-stream strm (number->string num)))
(define-method (print-object (strm <output-stream>)
(sym <symbol>))
(unless (interned? sym)
(write-stream strm "#:"))
(write-stream strm (symbol->string sym)))
(define-method (print-object (strm <output-stream>)
(pair <pair>))
(letrec ((write-pair
(lambda (pair)
(print-object strm (car pair))
((pair? (cdr pair))
(write-stream strm " ")
(write-pair (cdr pair)))
((null? (cdr pair)))
(write-stream strm " . ")
(print-object strm (cdr pair)))))))
(write-stream strm "(")
(write-pair pair)
(write-stream strm ")")))
(define-method (print-object (strm <output-stream>)
(val <null>))
(write-stream strm "()"))
(define-method (print-object (strm <output-stream>)
(str <string>))
(let* ((esc '((#\newline #\n) (#\tab #\t) (#\" #\") (#\\ #\\)))
(special (map car esc))
(len (string-length str)))
(write-stream strm #\")
(let loop ((p 0))
(when (< p len)
(let ((c (string-ref str p)))
((member? c special)
(write-stream strm #\\)
(write-stream strm (second (assq c esc))))
(write-stream strm c))))
(loop (+ p 1))))
(write-stream strm #\")))
(define-method (print-object (strm <output-stream>)
(bool <boolean>))
(write-stream strm #\#)
(if bool
(write-stream strm #\t)
(write-stream strm #\f)))
(define-method (print-object (strm <output-stream>)
(vect <vector>))
(write-stream strm "#(")
(let loop ((idx 0))
(when (< idx (vector-length vect))
(when (> idx 0)
(write-stream strm " "))
(print-object strm (vector-ref vect idx))
(loop (+ idx 1))))
(write-stream strm ")"))
(define-method (print-object (strm <output-stream>)
(htb <hashtab>))
(write-stream strm "#<hashtab>"))
(define-method (print-object (strm <output-stream>)
(char <char>))
((eq? char #\space) (write-stream strm "#\\space"))
((eq? char #\newline) (write-stream strm "#\\newline"))
((eq? char #\tab) (write-stream strm "#\\tab"))
(else (write-stream strm "#\\")
(write-stream strm char))))
(define-method (print-object (strm <output-stream>)
(prim <procedure>))
(write-stream strm "#<procedure>"))
(define-method (print-object (strm <output-stream>)
(prim <syntax-procedure>))
(write-stream strm "#<syntax-procedure>"))
(define-method (print-object (strm <output-stream>)
(prim <compiled-syntax-procedure>))
(write-stream strm "#<compiled-syntax-procedure>"))
(define-method (print-object (strm <output-stream>)
(prim <compiled-procedure>))
(write-stream strm "#<compiled-procedure>"))
(define-method (print-object (strm <output-stream>)
(prim <input-port>))
(write-stream strm "#<input-port>"))
(define-method (print-object (strm <output-stream>)
(prim <output-port>))
(write-stream strm "#<output-port>"))
(define-method (print-object (strm <output-stream>)
(prim <directory-stream>))
(write-stream strm "#<directory-stream>"))
(define-method (print-object (strm <output-stream>)
(prim <lazy-symbol>))
(write-stream strm "#G")
(print-object strm (lazy-symbol-value prim)))
(define-method (print-object (strm <output-stream>)
(prim <alien>))
(ssprintf strm "#<alien: 0x%s>" (integer->string (ffi:alien-to-int prim)
:base 16
:pad (if (provided? 'ffi)
(define-class <input-stream> ()
"most basic input stream abstraction")
(define (end-of-stream? obj)
"predicate to detect the end of a stream"
(eof-object? obj))
(define-generic read-stream-char
"read a character from an input stream")
(define-generic read-stream-upto
"read up to n characters from stream")
(define-method (read-stream-upto (strm <input-stream>)
(count <number>))
(let ((result (make-string count)))
(let loop ((idx 0))
(if (< idx count)
(let ((char (read-stream-char strm)))
(if (end-of-stream? char)
(string-set! result idx char)
(loop (+ idx 1)))))
(define-generic read-stream-until
"read stream until predicate is satisfied or end of stream")
(define-method (read-stream-until (strm <input-stream>)
(pred <procedure>))
(let ((result (make-string-buffer)))
(let loop ((char (read-stream-char strm)))
(if (end-of-stream? char)
(string-buffer->string result)
(write-stream result char)
(if (pred char)
(string-buffer->string result)
(loop (read-stream-char strm))))))))
(define-method (read-stream-until (strm <input-stream>)
(char <char>))
(read-stream-until strm
(lambda (ch)
(eq? ch char))))
(define-class <native-input-stream> (<input-stream>)
"input stream that wraps a native port"
(define stdin-stream (make <native-input-stream> 'port stdin))
(define-method (read-stream-char (strm <native-input-stream>))
(read-char (slot-ref strm 'port)))
;; a stream buffer can be written to or read from as a stream
(define-class <string-buffer> (<output-stream> <input-stream>)
"accumulates the values written to it in a string"
(define (make-string-buffer . initial-value)
"construct a new string buffer, optionally with an initial value"
(if initial-value
(make <string-buffer>
'string (car initial-value)
'string-length (string-length (car initial-value))
'storage-length (string-length (car initial-value))
'read-index 0)
(let ((length 64))
(make <string-buffer>
'string (make-string length)
'string-length 0
'storage-length length
'read-index 0))))
(define (string-buffer->string buffer)
"convert a <string-buffer> to a string"
(slot-ref buffer 'string))
(define (%copy-into target source count)
"private. assumes target is big enough"
(let loop ((idx 0))
(when (< idx count)
(string-set! target idx
(string-ref source idx))
(loop (+ idx 1)))
(define-method (write-stream (strm <string-buffer>)
(char <char>))
(let ((string-length (slot-ref strm 'string-length))
(storage-length (slot-ref strm 'storage-length))
(string (slot-ref strm 'string)))
;; ensure there is sufficient storage
(when (= string-length storage-length)
(let* ((new-length (* 2 storage-length))
(new-string (make-string new-length)))
(slot-set! strm 'string
(%copy-into new-string
(slot-set! strm 'storage-length new-length)
(set! string new-string)))
;; append the character
(string-set! string string-length char)
;; increment the string size
(slot-set! strm 'string-length (+ 1 string-length))
(define-method (read-stream-char (strm <string-buffer>))
(let ((read-index (slot-ref strm 'read-index))
(string-length (slot-ref strm 'string-length)))
(if (= read-index string-length)
(let ((val (string-ref (slot-ref strm 'string) read-index)))
(slot-set! strm 'read-index (+ 1 read-index))
(define (sprintf string . args)
"splice arguments into string at locations specified by the format
(let ((sb (make-string-buffer)))
(let loop ((idx 0)
(ch (string-ref string 0))
(args args))
((= (char->integer ch) 0) #t)
((eq? ch #\%)
(let ((next (string-ref string (+ idx 1))))
((= (char->integer next) 0) #t)
((eq? next #\s)
(write-stream sb (first args))
(loop (+ idx 2) (string-ref string (+ idx 2)) (rest args)))
((eq? next #\a)
(print-object sb (first args))
(loop (+ idx 2) (string-ref string (+ idx 2)) (rest args)))
(else (write-stream sb ch)
(write-stream sb next)
(loop (+ idx 2) (string-ref string (+ idx 2)) args)))))
(write-stream sb ch)
(loop (+ idx 1) (string-ref string (+ idx 1)) args))))
(string-buffer->string sb)))
(define (printf string . args)
"print the interpolated string to stdout-stream"
(write-stream stdout-stream
(apply* sprintf string args)))
(define (ssprintf stream string . args)
"print the interpolated STRING onto the supplied STREAM"
(write-stream stream
(apply* sprintf string args)))
(define (string-buffer-example)
"example of using string-buffer"
(set! tt (make-string-buffer "hello crazy world"))
(print-object stdout-stream (read-stream-until tt #\space))
(print-object stdout-stream (read-stream-until tt #\space))
(print-object stdout-stream (read-stream-until tt #\space))
(define-class <pushback-input-stream> (<input-stream>)
"wraps a stream in an interface that supports unreading characters"
(define (ensure-pushback-stream strm)
(if (instance-of? <pushback-input-stream> strm)
(make <pushback-input-stream>
'wrapped-stream strm
'buffer nil)))
(define-method (read-stream-char (strm <pushback-input-stream>))
(let ((buf (slot-ref strm 'buffer)))
(if buf
(let ((char (car buf)))
(slot-set! strm 'buffer (cdr buf))
;; no buffer, read stream directly
(read-stream-char (slot-ref strm 'wrapped-stream)))))
(define-generic unread-stream-char
"return a character read from a stream back to that stream to be
read again")
(define-method (unread-stream-char (strm <pushback-input-stream>)
(char <char>))
(slot-set! strm 'buffer
(cons char (slot-ref strm 'buffer)))