diff --git a/configuration.sc b/configuration.sc index 5565cb4..d15e42b 100644 --- a/configuration.sc +++ b/configuration.sc @@ -3,7 +3,7 @@ (export define-config define-config-table) (import (chezscheme)) - ;;(define-config package.sc '()) + (define-syntax define-config (lambda (stx) (syntax-case stx () @@ -65,7 +65,7 @@ (read p))) '())) (define tmps - (let ([quer (assq 'var readed-table)]) + (let ([quer (assoc 'var readed-table)]) (if quer (box (cdr quer)) (box default-value)))) ... @@ -80,7 +80,7 @@ (cons 'var (unbox tmps)) (filter (lambda (x) - (not (eq? (car x) 'var))) + (not (equal? (car x) 'var))) (list (cons 'var (unbox tmps)) ...))) p))))])) ...))]))) diff --git a/data.sc b/data.sc index 1423f20..ab07842 100644 --- a/data.sc +++ b/data.sc @@ -2,6 +2,7 @@ (library (core data) (export (rename [internal-queue queue]) queue? queue-push queue-pop! queue-push! + queue-map (rename [internal-stream stream] [stream-null!? stream-null?] [internal-stream? stream?]) @@ -48,6 +49,10 @@ (define (queue-empty? q) (and (null? (queue-head q)) (null? (queue-tail q)))) + (define (queue-map f q) + (make-queue (map f (queue-head q)) + (map f (queue-tail q)))) + ;;; diff --git a/generic.sc b/generic.sc index 17d3608..b15e262 100644 --- a/generic.sc +++ b/generic.sc @@ -26,46 +26,70 @@ (library (core generic) - (export set-generic! map-generic first second third fourth + (export generic-set! generic-map first second third fourth fifth sixth seventh eigth ninth tenth eleventh twelfth - push + define-accessor generic-set-property ) - (import (chezscheme) (core syntax) (for (core syntax) expand)) + (import (chezscheme) (core syntax) (for (core syntax) expand) + (core data)) (meta define index-identifiers '()) - (define-syntax set-generic! + (define-syntax generic-set-property (syntax-rules ())) + (trace-define-syntax define-accessor (lambda (stx) - (syntax-case stx (car cdr vector-ref list-ref if - fxvector-ref) - [(_ (if condition var1 var2) value) - #'(if condition (set-generic! var1 value) - (set-generic! var2 value))] - [(_ (fxvector-ref var index) value) - #'(fxvector-set! var index value)] - [(_ (car var) value) - #'(set-car! var value)] - [(_ (cdr var) value) - #'(set-cdr! var value)] - [(_ (vector-ref var index) value) - #'(vector-set! var index value)] - [(_ (list-ref var index) value) - #'(list-set! var index value)] - [(_ (maybe-accessor var) value) - (assoc/free-identifier=? #'maybe-accessor index-identifiers) - (let ([idx - (cdr (assoc/free-identifier=? #'maybe-accessor index-identifiers))]) - #`(let ([real-var var]) - (cond - [(list? real-var) (list-set! var #,idx value)] - [(vector? var) (vector-set! var #,idx value)] - [else (error 'set-generic! "unknown datatype")])))] - [(_ . any-other-forms) #'(set! . any-other-forms)] - ))) + (syntax-case stx () + [(_ (name args ...) body) + #'(begin (define (name args ...) body) + (define-property name generic-set-property + (lambda (stx) + (syntax-case stx () + [(name args ... value) #'(generic-set! body value)]))))]))) + (define-syntax generic-set! + (lambda (stx) + (lambda (lookup) + (syntax-case stx (car cdr vector-ref list-ref if + fxvector-ref eq-hashtable-ref string-ref) + [(_ (string-ref s idx) value) + #'(string-set! s idx value)] + [(_ (eq-hashtable-ref table key rest ...) value) + #'(eq-hashtable-set! table key value)] + [(_ (if condition var1 var2) value) + #'(if condition (set-generic! var1 value) + (set-generic! var2 value))] + [(_ (fxvector-ref var index) value) + #'(fxvector-set! var index value)] + [(_ (car var) value) + #'(set-car! var value)] + [(_ (cdr var) value) + #'(set-cdr! var value)] + [(_ (vector-ref var index) value) + #'(vector-set! var index value)] + [(_ (list-ref var index) value) + #'(list-set! var index value)] + [(_ (maybe-accessor var) value) + (assoc/free-identifier=? #'maybe-accessor index-identifiers) + (let ([idx + (cdr (assoc/free-identifier=? #'maybe-accessor index-identifiers))]) + #`(let ([real-var var]) + (cond + [(list? real-var) (list-set! var #,idx value)] + [(vector? var) (vector-set! var #,idx value)] + [(fxvector? var) (fxvector-set! var #,idx value)] + [else (error 'set-generic! "unknown datatype")])))] + [(_ (maybe-accessor args ...) value) + (lookup #'maybe-accessor #'generic-set-property) + ((lookup #'maybe-accessor #'generic-set-property) + #'(maybe-accessor args ... value))] + [(_ . any-other-forms) #'(set! . any-other-forms)] + )))) + - (define (map-generic f list-or-vector) + (define (generic-map f list-or-vector) (cond [(list? list-or-vector) (map f list-or-vector)] [(vector? list-or-vector) (vector-map f list-or-vector)] + [(stream? list-or-vector) (stream-map f list-or-vector)] + [(queue? list-or-vector) (queue-map f list-or-vector)] [else (error 'map-generic "unknown datatype")])) (define (list-set! var index value) @@ -82,6 +106,8 @@ (cond [(list? x) (list-ref x index)] [(vector? x) (vector-ref x index)] + [(fxvector? x) (fxvector-ref x index)] + [(stream? x) (stream-ref x index)] [else (error 'fourth "unknown datatype")])))]))) (make-index-identifier 0 first) (make-index-identifier 1 second) @@ -96,23 +122,8 @@ (make-index-identifier 10 eleventh) (make-index-identifier 11 twelfth) - (define (push container value) - (cond - [(list? container) (cons value container)] - [(vector? container) (let* ([l (vector-length container)] - [new (make-vector (+ l 1))]) - (vector-set! new 0 value) - (let loop ([s 1]) - (if (>= s (+ l 1)) - (void) - (begin (vector-set! new s (vector-ref container (- s 1))) - (loop (+ s 1))))) - new)] - [else (error 'push "unknown datatype")] - )) - + ;;;;;;;;;;;;;;;; ) - (import (core generic)) diff --git a/io.sc b/io.sc index ffd10f0..c9c454b 100644 --- a/io.sc +++ b/io.sc @@ -1,7 +1,7 @@ (library (core io) (export file->string file-append port->string read-line) - (import (chezscheme)) + (import (chezscheme) (core string)) (define (file->string fname) (port->string (open-input-file fname)) ) @@ -37,6 +37,17 @@ (reverse (remove-r acc)) (loop (cons c acc)))))) + (define (remove-r x) + (define strlen (string-length x)) + (define c (string-ref x strlen)) + (if (char=? c #\return) + (substring x 0 (- strlen 1)) + x)) + + (define (file->lines f) + (define str (file->string f)) + (map remove-r (split str #\newline))) + )