Changeset 35146 in project


Ignore:
Timestamp:
02/17/18 22:47:23 (7 months ago)
Author:
kon
Message:

dep make/copy 4 make-with-copy , add csi+csc run

Location:
release/4/coops-utils/trunk
Files:
1 added
4 edited

Legend:

Unmodified
Added
Removed
  • release/4/coops-utils/trunk/coops-extras.scm

    r34763 r35146  
    77(;export
    88  slot@
    9   make/copy
     9  make-with-copy
    1010  describe-object describe-object-slot
    1111  ;
    12   print-closure )
     12  print-closure
     13  ;DEPRECATED
     14  make/copy)
    1315
    14 (import scheme)
     16(import scheme chicken)
    1517
    16 (import chicken)
    17 
    18 (import (only data-structures o))
    19 (require-library data-structures)
    20 
    21 (import (only extras format))
    22 (require-library extras)
    23 
    24 (import (only srfi-1 cons* fold remove))
    25 (require-library srfi-1)
    26 
    27 (import (only srfi-13 string-pad))
    28 (require-library srfi-13)
    29 
    30 (require-extension coops-introspection coops)
     18(use
     19  (only data-structures o)
     20  (only extras format)
     21  (only srfi-1 cons* fold remove)
     22  (only srfi-13 string-pad)
     23  coops-introspection coops)
    3124
    3225(declare
     
    9790
    9891;use w/ <primitive-object> is very suspect
    99 (define (make/copy obj . initforms)
    100   (let ((class (class-of (check-instance 'make/copy obj))))
     92(define (make-with-copy obj . initforms)
     93  (let ((class (class-of (check-instance 'make-with-copy obj))))
    10194    (apply make class (shadowed-initforms obj initforms class)) ) )
    10295
     
    110103      ;then obj used thru a coops interface
    111104      (format out "coops instance of class `#t': ~S~%" obj)
    112       ;else
     105      ;else an instance
    113106      (let* (
    114107        (slots
     
    139132(define-method (describe-object (prim <primitive-object>)
    140133                  #!optional (out (current-output-port)))
    141   (format out
    142     "coops instance of primitive class `~A': ~S~%"
     134  (format out "coops instance of primitive class `~A': ~S~%"
    143135    (class-name (class-of prim)) prim) )
    144136
    145137(define-method (describe-object (proc <procedure>)
    146138                  #!optional (out (current-output-port)))
    147   (format out
    148     "~A~%"
     139  (format out "~A~%"
    149140    (if (generic-procedure? proc)
    150141      "coops instance of `<generic-procedure>'"
     
    159150(define (print-closure proc #!optional (out (current-output-port)))
    160151  (let ((idx 0))
    161     (format out
    162       "~A: #x~X~%"
     152    (format out "~A: #x~X~%"
    163153      idx
    164154      (closure-C-address (check-closure 'print-closure proc)))
     
    168158        (format out "~A: ~S~%" i (##sys#slot proc i)) ) ) ) )
    169159
     160;;;DEPRECATED
     161
     162(define make/copy make-with-copy)
     163
    170164) ;coops-extras
  • release/4/coops-utils/trunk/coops-utils.meta

    r34762 r35146  
    1717  "coops-utils.scm" "coops-extras.scm"
    1818  "coops-introspection-tinyclos.scm"
    19   "tests/run.scm") )
     19  "tests/run.scm" "tests/coops-utils-test.scm") )
  • release/4/coops-utils/trunk/coops-utils.setup

    r34762 r35146  
    1515;; Module
    1616
    17 (setup-shared-extension-module 'coops-introspection (extension-version "1.1.0")
     17(setup-shared-extension-module 'coops-introspection (extension-version "1.2.0")
    1818  #:types? #t
    1919  #:inline? #t
    2020  #:compile-options `(,@*EGG-CSC-OPTIONS* -inline-limit 240) )
    2121
    22 (setup-shared-extension-module 'coops-extras (extension-version "1.1.0")
     22(setup-shared-extension-module 'coops-extras (extension-version "1.2.0")
    2323  #:types? #t
    2424  #:inline? #t
    2525  #:compile-options *EGG-CSC-OPTIONS* )
    2626
    27 (setup-shared-extension-module 'coops-introspection-tinyclos (extension-version "1.1.0")
     27(setup-shared-extension-module 'coops-introspection-tinyclos (extension-version "1.2.0")
    2828  #:types? #t
    2929  #:inline? #t
     
    3232;; Egg Module
    3333
    34 (setup-shared-extension-module *EGG-NAME* (extension-version "1.1.0")
     34(setup-shared-extension-module *EGG-NAME* (extension-version "1.2.0")
    3535  #:types? #t
    3636  #:inline? #t
  • release/4/coops-utils/trunk/tests/run.scm

    r34762 r35146  
    1 ;;;; coops-utils test
    2 ;;;; Kon Lovett
    31
    4 (use test)
     2(define EGG-NAME "coops-utils")
    53
    6 (use srfi-1 srfi-13)
     4;chicken-install invokes as "<csi> -s run.scm <eggnam> <eggdir>"
    75
    8 (use coops)
     6(use files)
    97
    10 (use coops-utils)
    11 #| ;SAME AS
    12 (use coops-introspection)
    13 (use coops-introspection-tinyclos)
    14 (use coops-extras)
    15 |#
     8;no -disable-interrupts
     9(define *csc-options* "-inline-global -scrutinize -optimize-leaf-routines -local -inline -specialize -unsafe -no-trace -no-lambda-info -clustering -lfa2")
    1610
    17 (test-assert (class? <standard-class>))
     11(define *args* (argv))
    1812
    19 (test-assert (class? <standard-object>))
     13(define (test-name #!optional (eggnam EGG-NAME))
     14  (string-append eggnam "-test") )
    2015
    21 ;; setup test reference environment
     16(define (egg-name #!optional (def EGG-NAME))
     17  (cond
     18    ((<= 4 (length *args*))
     19      (cadddr *args*) )
     20    (def
     21      def )
     22    (else
     23      (error 'test "cannot determine egg-name") ) ) )
    2224
    23 (define-class <s1xy> () ((x 's1xy-x) (y 's1xy-y)))
    24 (define-class <s1ab> () ((a 's1ab-a) (b 's1ab-b)))
    25 (define-class <s2xz> () ((x 's2xz-x) (z 's2xz-z)))
    26 (define-class <s2ac> () ((a 's2ac-a) (c 's2ac-c)))
     25;;;
    2726
    28 (define-class <s1xys1ab> (<s1xy> <s1ab>)
    29   ((x 's1xys1ab-x) (y 's1xys1ab-y) (a 's1xys1ab-a) (b 's1xys1ab-b) (me '<s1xys1ab>)))
    30 (define-class <s2xzs2ac> (<s2xz> <s2ac>)
    31   ((x 's2xzs2ac-x) (z 's2xzs2ac-z) (a 's2xzs2ac-a) (c 's2xzs2ac-c)))
     27(set! EGG-NAME (egg-name))
    3228
    33 (define-class <s1xys2xz> (<s1xy> <s2xz>) ())
    34 (define-class <s2xzs1ab> (<s2xz> <s1ab>) ())
     29(define (run-test #!optional (eggnam EGG-NAME) (cscopts *csc-options*))
     30  (let ((tstnam (test-name eggnam)))
     31    (print "*** csi ***")
     32    (system (string-append "csi -s " (make-pathname #f tstnam "scm")))
     33    (newline)
     34    (print "*** csc (" cscopts ") ***")
     35    (system (string-append "csc" " " cscopts " " (make-pathname #f tstnam "scm")))
     36    (system (make-pathname (cond-expand (unix "./") (else #f)) tstnam)) ) )
    3537
    36 (define-generic (foo abc xyz))
     38(define (run-tests eggnams #!optional (cscopts *csc-options*))
     39  (for-each (cut run-test <> cscopts) eggnams) )
    3740
    38 (define-method (foo primary: (abc <s1xy>) (xyz <s1ab>)) 'primary-<s1xy><s1ab>)
    39 (define-method (foo before: (abc <s1xy>) (xyz <s1ab>)) 'before-<s1xy><s1ab>)
    40 (define-method (foo after: (abc <s1xy>) (xyz <s1ab>)) 'after-<s1xy><s1ab>)
    41 (define-method (foo around: (abc <s1xy>) (xyz <s1ab>)) 'around-<s1xy><s1ab>)
     41;;;
    4242
    43 (define-method (foo primary: (abc <s2xz>) (xyz <s2ac>)) 'primary-<s2xz><s2ac>)
    44 (define-method (foo before: (abc <s2xz>) (xyz <s2ac>)) 'before-<s2xz><s2ac>)
    45 (define-method (foo after: (abc <s2xz>) (xyz <s2ac>)) 'after-<s2xz><s2ac>)
    46 (define-method (foo around: (abc <s2xz>) (xyz <s2ac>)) 'around-<s2xz><s2ac>)
    47 
    48 (test (list <s2xz> <standard-object> <s1ab>) (class-precedence-list <s2xzs1ab>))
    49 (test '(x z a b) (class-slots <s2xzs1ab>))
    50 
    51 (test-assert (class? <s2xzs2ac>))
    52 (test (list <standard-object>) (class-direct-supers <s2ac>))
    53 (test '(a c) (class-direct-slots <s2ac>))
    54 
    55 (test-assert (class? <s1xys1ab>))
    56 (test (list <s1xy> <s1ab>) (class-direct-supers <s1xys1ab>))
    57 (test '(me) (class-direct-slots <s1xys1ab>))
    58 
    59 (test 'foo (generic-name foo))
    60 (test '(abc xyz) (generic-specialized-arguments foo))
    61 (test-assert (eq? 2 (length (generic-primary-methods foo))))
    62 (let ((primaries (generic-methods foo)))
    63   (for-each
    64     (lambda (x)
    65       (let ((specials (method-specializers x)))
    66         (test-assert (list? specials))
    67         (test-assert (every class? specials)) )
    68       (test-assert (procedure? (method-procedure x)))
    69       (test-assert (method? x)) )
    70     primaries) )
    71 
    72 (define s1xy-inst (make <s1xy> 'x 1 'y 2))
    73 (test-assert (instance? s1xy-inst))
    74 (test-assert (instance-of? s1xy-inst <s1xy>))
    75 
    76 (describe-object s1xy-inst)
    77 
    78 #| FIXME - y = 's1xy-y ?
    79 (define s1xy-inst-x (make <s1xy> 'x 1))
    80 (test-assert (instance? s1xy-inst-x))
    81 (test-assert (instance-of? s1xy-inst-x <s1xy>))
    82 (describe-object s1xy-inst-x)
    83 ;=>
    84 ;coops instance of class `<s1xy>':
    85 ;x: 1
    86 ;y: s1xy-y
    87 |#
    88 
    89 (define-class <first> () (next))
    90 (define-class <second> (<first>) ())
    91 (define-class <third> (<second>) ())
    92 
    93 (define 1st (make <first> 'next (make <second> 'next (make <third> 'next "the end"))))
    94 
    95 (test "the end" (slot@ 1st next next next))
    96 (slot@ 1st next next next = "still the end")
    97 (test "still the end" (slot@ 1st next next next))
    98 
    99 ;make/copy
    100 (let ((inst (make/copy s1xy-inst 'y 23)))
    101   (test "make/copy" 23 (slot@ inst y)) )
    102 
    103 (let ()
    104   (define-class city () (name (market-class reader: city-market-class) sellers buyers (goods accessor: city-goods)))
    105   (define temphawa (make city 'name "Hawa" 'market-class 2))
    106   (test-assert "make/copy temphawa" (make/copy temphawa)) )
    107 
    108 ;primitive-instance?
    109 
    110 ;---
    111 #|
    112 ;; Named (has a name) "concept"
    113 
    114 (define-generic (name obj))
    115 (define-class <named> () (
    116   (namsym #:reader name) ) )
    117 
    118 ;; Moves foreward thru a set of values "concept"
    119 
    120 (define-generic (step-function obj))
    121 (define-class <stepper> () (
    122   (nxtval #:reader step-function) ) )
    123 (define-generic (next-value obj))
    124 (define-method (next-value (obj <stepper>)) ((step-function obj)))
    125 
    126 ;; Parameterized extension "concept"
    127 
    128 (define-generic (parameters obj))
    129 (define-generic (basis obj))
    130 (define-class <parameterized> () (
    131   (parms #:reader parameters)
    132   (src #:reader basis) ) )
    133 
    134 ;; Parameterized generative set of random values "concept"
    135 
    136 (define-class <random-distribution> (<named> <parameterized> <stepper>) (
    137   temp ) )
    138 
    139 ;; Create an instance of <random-distribution> where the arguments are
    140 ;; the same as the documented procedural distribution API.
    141 ;;
    142 ;; SRFI 27 API: ({some distribution constructor} arg...)
    143 ;;      OO API: (make-random-distribution {some distribution constructor} arg...)
    144 
    145 (define-syntax make-random-distribution
    146   (syntax-rules ()
    147     ((_ ?ctor ?arg0 ...)
    148       (make <random-distribution> 'temp (?ctor ?arg0 ...)) ) ) )
    149 
    150 (define-method (initialize-instance (obj <random-distribution>))
    151   ; The 'ctor' should be a globally defined procedure compiled
    152   ; with procedure-information. So if following nomenclature then the last
    153   ; procedure name element will be the kind of distribution.
    154   (let* ((temp (slot-value obj 'temp))
    155          (ctor (car temp))
    156          (procinfo (procedure-information ctor))
    157          (name (and procinfo (pair? procinfo) (symbol->string (car procinfo))))
    158          (name (and name
    159                     (and-let* ((kndpos (string-index-right name #\-)))
    160                       (substring/shared name (fx+ kndpos 1)) ) ) )
    161          (dstr-vals (receive (apply ctor (cdr temp))))
    162          (parms (and (fx<= 2 (length dstr-vals)) (receive ((second dstr-vals))))) )
    163     (set! (slot-value obj 'temp) #f) ;"free" the "any" slot
    164     (set! (slot-value obj 'namsym) (string->symbol name))
    165     (set! (slot-value obj 'nxtval) (first dstr-vals))
    166     (set! (slot-value obj 'parms) (and parms (drop-right parms 1))) ) )
    167 |#
    168 
    169 (test-exit)
     43(run-test)
Note: See TracChangeset for help on using the changeset viewer.