#|-------------------- 1.0.0 |# "./coops-extras.scm" 3053 ;;;; coops-extras.scm ;;;; Kon Lovett, Aug '10 (module coops-extras (;export slot@ make/copy describe-object) (import scheme chicken (only extras fprintf) (only srfi-1 fold remove) (only srfi-13 string-pad) coops coops-introspection) (require-library extras srfi-1 srfi-13 coops-introspection coops) ;;; Helpers (define-inline (symbol-length sym) (string-length (symbol->string sym))) ; memq is not specific enough (define-inline (initslot? slot initforms) (let loop ((initforms initforms)) (and (not (null? initforms)) (or (eq? slot (car initforms)) (loop (cddr initforms)) ) ) ) ) (define-inline (slot-values x slots #!optional (base '())) (fold (lambda (slot ls) (cons slot (cons (slot-value x slot) ls))) base slots) ) (define-inline (*class-slots class) (slot-value class 'slots)) (define-inline (shadowed-initforms x initforms #!optional (class (class-of x))) (slot-values x (remove (cut initslot? <> initforms) (*class-slots class)) initforms) ) ;;; Extras ;; ; sub-instance slot reference (define-syntax slot@ (syntax-rules (=) ((_ o) o ) ((_ o slot = v) (set! (slot-value o 'slot) v) ) ((_ o slot . slots) (slot@ (slot-value o 'slot) . slots)) ) ) ;; ; use w/ is very suspect (define (make/copy x . initforms) (check-instance 'make/copy x) (let ((class (class-of x))) (apply make class (shadowed-initforms x initforms class)) ) ) ;; (define-generic (describe-object obj)) (define-method (describe-object (obj #t) #!optional (out (current-output-port))) (let ((class (class-of obj))) (cond ((eq? class #t) ; specific in that obj used thru a coops interface ; but might be misleading - (display obj out) perhaps? (fprintf out "coops instance of class `#t': ~S~%" obj) ) (else (fprintf out "coops instance of class `~A':~%" (class-name class)) (let* ((slots (*class-slots class)) (maxlen (fold (lambda (slot len) (fxmax (symbol-length slot) len)) 0 slots)) ) (for-each (lambda (slot) (display (string-pad (symbol->string slot) maxlen) out) (display " : " out) (if (slot-initialized? obj slot) (write (slot-value obj slot) out) (display "#" out) ) (newline out) ) slots) ) ) ) ) ) (define-method (describe-object (prim ) #!optional (out (current-output-port))) (fprintf out "coops instance of primitive class `~A': ~S~%" (class-name (class-of prim)) prim) ) (define-method (describe-object (proc ) #!optional (out (current-output-port))) (if (generic? proc) (fprintf out "coops instance of `'~%") (fprintf out "coops instance of primitive class `'~%") ) ) (define-method (describe-object (class ) #!optional (out (current-output-port))) (fprintf out "coops standard-class `~A'~%" (class-name class)) ) ) ;coops-extras #|-------------------- 1.0.0 |# "./coops-introspection.scm" 5543 ;;;; coops-introspection.scm ;;;; Kon Lovett, Aug '10 ;; Issues ;; ;; - all slot options are "lost" after definition. ;; ;; - generic-procedure introspection is dicey since the generic ;; has no "entity" representation & methods are not 1st-class. (module coops-introspection (;export ; class-cpl class-supers ;= class-precedence-list primitive? ;= primitive-instance? generic-methods ;= generic-primary-methods ; instance-of? class? check-class error-class instance? check-instance error-instance generic? check-generic error-generic method? check-method error-method primitive-instance? ; class-precedence-list class-direct-supers class-slots class-direct-slots ; generic-anonymous? generic-name generic-specialized-arguments generic-primary-methods generic-before-methods generic-after-methods generic-around-methods ; method-specializers method-procedure) (import scheme chicken (only srfi-1 every fold-right lset-union! lset-difference) (only type-checks define-check+error-type) coops) (require-library srfi-1 type-checks coops) ;;; Helpers (define-inline (*class-slots class) (slot-value class 'slots)) (define-inline (*class-supers class) (slot-value class 'class-precedence-list)) (define-inline (union-class-slots classes) (fold-right (lambda (class ls) (lset-union! eq? ls (*class-slots class))) '() classes) ) (define-inline (union-class-supers classes) (fold-right (lambda (class ls) (lset-union! eq? ls (*class-supers class))) '() classes) ) (define-inline (*class-supers-slots class) (union-class-slots (*class-supers class))) (define-inline (*class-supers-supers class) (union-class-supers (*class-supers class))) (define-inline (*subclass? c1 c2) (or (eq? c1 c2) (subclass? c1 c2))) (define (generic-name? obj) (or (not obj) (symbol? obj))) (define (boxed-list? obj) (and (vector? obj) (= 1 (vector-length obj)) (list? (vector-ref obj 0))) ) (define (error-generic-form loc obj idx) (error loc "generic closure form violation" obj idx) ) (define-inline (check-generic-form loc obj0 idx pred) (check-generic loc obj0) (let ((obj (##sys#slot obj0 idx))) (unless (pred obj) (error-generic-form loc obj0 idx) ) obj ) ) (define (check-generic-methods loc obj idx) (vector-ref (check-generic-form loc obj idx boxed-list?) 0) ) ;;; Predicates (define (instance-of? x class) (*subclass? (class-of x) class)) (define (class? x) (instance-of? x )) (define (instance? x) (let ((class-x (class-of x))) (not (or (eq? class-x #t) ; unknown primitive is not considered an instance (*subclass? class-x ))) ) ) (define (primitive-instance? x) (instance-of? x )) (define (method? obj) (and (pair? obj) (let ((specializers (car obj))) (and (list? specializers) (every class? specializers))) (procedure? (cdr obj))) ) ;;; Errors & Checks (define-check+error-type class class? "coops-class") (define-check+error-type instance instance? "coops-instance") (define-check+error-type generic generic-procedure? "coops-generic") (define-check+error-type method method? "coops-method") ;;; Introspection ;; Class Properties (define (class-precedence-list class) (check-class 'class-precedence-list class) (*class-supers class) ) (define (class-slots class) (check-class 'class-slots class) (*class-slots class) ) ;; Class Direct Properties ; those supers declared in the direct class & not inherited (define (class-direct-supers class) (check-class 'class-direct-supers class) (lset-difference eq? (*class-supers class) (*class-supers-supers class))) ; those slots declared in the direct class & not inherited (define (class-direct-slots class) (check-class 'class-direct-slots class) (lset-difference eq? (*class-slots class) (*class-supers-slots class)) ) ;; #; ;Bad, Bad, Bad (define (print-closure p) (##sys#check-closure p 'print-closure) (print "0\t: #x" (number->string (##sys#peek-unsigned-integer p 0) 16)) (let ((size (##sys#size p))) (do ((i 1 (add1 i))) ((= i size)) (print i "\t: " (##sys#slot p i)) ) ) ) ;; Generic Properties (define (generic-anonymous? generic) (and (generic-procedure? generic) (not (##sys#slot generic 1))) ) (define (generic-name generic) (check-generic-form 'generic-name generic 1 generic-name?) ) (define (generic-specialized-arguments generic) (check-generic-form 'generic-specialized-args generic 7 pair?) ) (define (generic-primary-methods generic) (check-generic-methods 'generic-primary-methods generic 2) ) (define (generic-before-methods generic) (check-generic-methods 'generic-before-methods generic 3) ) (define (generic-after-methods generic) (check-generic-methods 'generic-after-methods generic 4) ) (define (generic-around-methods generic) (check-generic-methods 'generic-around-methods generic 5) ) ;; Method Properties (define (method-specializers method) (check-method 'method-specializers method) (car method) ) (define (method-procedure method) (check-method 'method-procedure method) (cdr method) ) ;;; Synonyms (define class-cpl class-precedence-list) (define class-supers class-precedence-list) (define primitive? primitive-instance?) (define generic? generic-procedure?) (define generic-methods generic-primary-methods) ) ;coops-introspection #|-------------------- 1.0.0 |# "./coops-utils.meta" 394 ;;;; coops-utils.meta -*- Hen -*- ((egg "coops-utils.egg") (category misc) (author "[[kon lovett]]") (license "BSD") (doc-from-wiki) (synopsis "coops-utils") (depends (setup-helper "1.5.2") (coops "1.92") (check-errors "1.12.6")) (test-depends test) (files "coops-utils.meta" "coops-introspection.scm" "coops-utils.scm" "coops-extras.scm" "coops-utils.setup" "tests/run.scm") ) #|-------------------- 1.0.0 |# "./coops-utils.scm" 226 ;;;; coops-utils.scm -*- Hen -*- ;;;; Kon Lovett, Dec '12 (module coops-utils () (import scheme chicken) (reexport coops-introspection coops-extras) (require-library coops-introspection coops-extras) ) ;coops-utils #|-------------------- 1.0.0 |# "./coops-utils.setup" 666 ;;;; coops-utils.setup -*- Hen -*- (use setup-helper-mod) (verify-extension-name "coops-utils") (setup-shared-extension-module 'coops-introspection (extension-version "1.0.0") #:types? #t #:inline? #t #:compile-options '(-scrutinize -local -fixnum-arithmetic -no-procedure-checks) ) (setup-shared-extension-module 'coops-extras (extension-version "1.0.0") #:types? #t #:inline? #t #:compile-options '(-scrutinize -local -fixnum-arithmetic -no-procedure-checks) ) (setup-shared-extension-module 'coops-utils (extension-version "1.0.0") #:types? #t #:inline? #t #:compile-options '(-scrutinize -local -fixnum-arithmetic -no-procedure-checks) )