Changeset 38938 in project


Ignore:
Timestamp:
08/30/20 19:07:09 (4 weeks ago)
Author:
Kon Lovett
Message:

add -strict-types, type is interface

Location:
release/5/symbol-utils/trunk
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • release/5/symbol-utils/trunk/symbol-lolevel-utils.scm

    r38406 r38938  
    1616
    1717(: interned-symbol? (symbol --> boolean))
    18 ;
     18
    1919(define (interned-symbol? sym)
    2020  (##sys#interned-symbol? (check-symbol 'interned-symbol? sym)) )
  • release/5/symbol-utils/trunk/symbol-name-utils.scm

    r38406 r38938  
    3333;;; Support
    3434
     35(: exploded-qualified-symbol=? (string string string string --> boolean))
     36(: exploded-qualified-symbol<? (string string string string --> boolean))
     37(: *symbol-printname-details (symbol (or keyword symbol) --> string string))
     38(: ->symbol (* --> symbol))
     39(: ->uninterned-symbol (* -> symbol))
     40(: keyword->symbol (keyword --> symbol))
     41(: keyword->uninterned-symbol (keyword -> symbol))
     42(: symbol->keyword ((or keyword symbol) --> keyword))
     43(: symbol-printname-details ((or keyword symbol) --> string string))
     44(: symbol-printname=? ((or keyword symbol) (or keyword symbol) --> boolean))
     45(: symbol-printname<? ((or keyword symbol) (or keyword symbol) --> boolean))
     46(: symbol-printname-length ((or keyword symbol) --> fixnum))
     47(: max-symbol-printname-length ((list-of symbol) --> fixnum))
     48
    3549;;
    3650
    37 (: exploded-qualified-symbol=? (string string string string --> boolean))
    38 ;
    3951(define (exploded-qualified-symbol=? px sx py sy)
    4052  (and (string=? px py) (string=? sx sy)) )
    4153
    42 (: exploded-qualified-symbol<? (string string string string --> boolean))
    43 ;
    4454(define (exploded-qualified-symbol<? px sx py sy)
    4555  (or
     
    4959;;
    5060
    51 (: *symbol-printname-details (symbol (or keyword symbol) --> string string))
    52 ;
    5361(define (*symbol-printname-details loc sym)
    5462  (cond
     
    6068;;
    6169
    62 (: ->symbol (* --> symbol))
    63 ;
    6470(define (->symbol obj)
    6571  (cond
     
    6874    (else           (string->symbol (->string obj)) ) ) )
    6975
    70 (: ->uninterned-symbol (* -> symbol))
    71 ;
    7276(define (->uninterned-symbol obj)
    7377  (cond
     
    7882;;
    7983
    80 (: keyword->symbol (keyword --> symbol))
    81 ;
    8284(define (keyword->symbol kwd)
    8385  (string->symbol (keyword->string (check-keyword 'keyword->symbol kwd))) )
    8486
    85 (: keyword->uninterned-symbol (keyword -> symbol))
    86 ;
    8787(define (keyword->uninterned-symbol kwd)
    8888  (string->uninterned-symbol (keyword->string (check-keyword 'keyword->uninterned-symbol kwd))) )
     
    9393;which means a keyword and a symbol of the same name have the same printname.
    9494
    95 (: symbol->keyword ((or keyword symbol) --> keyword))
    96 ;
    9795(define (symbol->keyword sym)
    9896  (cond
     
    10098    (else           (string->keyword (symbol->string sym)) ) ) )
    10199
    102 (: symbol-printname-details ((or keyword symbol) --> string string))
    103 ;
    104100(define (symbol-printname-details sym)
    105101  (let-values (
     
    110106;FIXME (forall (a ...) (a a --> boolean))
    111107
    112 (: symbol-printname=? ((or keyword symbol) (or keyword symbol) --> boolean))
    113 ;
    114108(define (symbol-printname=? x y)
    115109  (let-values (
     
    118112    (exploded-qualified-symbol=? px sx py sy) ) )
    119113
    120 (: symbol-printname<? ((or keyword symbol) (or keyword symbol) --> boolean))
    121 ;
    122114(define (symbol-printname<? x y)
    123115  (let-values (
     
    128120;;
    129121
    130 (: symbol-printname-length ((or keyword symbol) --> fixnum))
    131 ;
    132122(define (symbol-printname-length sym)
    133123  (cond
     
    138128      (string-length (symbol->string (check-symbol 'symbol-printname-length sym))) ) ) )
    139129
    140 (: max-symbol-printname-length ((list-of symbol) --> fixnum))
    141 ;
    142130(define (max-symbol-printname-length syms)
    143131  (if (null? (check-list 'max-symbol-printname-length syms))
  • release/5/symbol-utils/trunk/symbol-utils.egg

    r38406 r38938  
    1414  (extension symbol-lolevel-utils
    1515    (types-file)
    16     (csc-options "-O3" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks") )
     16    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks") )
    1717  (extension symbol-name-utils
    1818    (types-file)
    19     (csc-options "-O3" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks") )
     19    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks") )
    2020  (extension symbol-value-utils
    2121    (types-file)
    22     (csc-options "-O3" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks") )
     22    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks") )
    2323  (extension symbol-utils
    2424    (types-file)
    2525    (component-dependencies symbol-lolevel-utils symbol-name-utils symbol-value-utils)
    26     (csc-options "-O3" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks") ) ) )
     26    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks") ) ) )
  • release/5/symbol-utils/trunk/tests/run.scm

    r38449 r38938  
    99;chicken-install invokes as "<csi> -s run.scm <eggnam> <eggdir>"
    1010
    11 (import (only (chicken pathname) make-pathname))
     11(import (only (chicken pathname)
     12  make-pathname pathname-file pathname-replace-directory pathname-strip-extension))
    1213(import (only (chicken process) system))
    1314(import (only (chicken process-context) argv))
    1415(import (only (chicken format) format))
     16(import (only (chicken file) file-exists? find-files))
     17(import (only (chicken irregex) irregex irregex-match?))
    1518
    16 (define (test-filename test-name)
    17   (string-append test-name "-test") )
     19(define *args* (argv))
    1820
    1921(define (egg-name args #!optional (def EGG-NAME))
    2022  (cond
    21     ((<= 4 (length *args*))
    22       (cadddr *args*) )
    23     (def
    24       def )
     23    ((<= 4 (length *args*)) (cadddr *args*) )
     24    (def                    def )
    2525    (else
    26       (error 'test "cannot determine egg-name") ) ) )
    27 
    28 ;;
    29 
    30 (define *args* (argv))
    31 (define *egg* (egg-name *args*))
    32 (define *tests* `(,*egg*))
     26      (error 'run "cannot determine egg-name") ) ) )
    3327
    3428(define *current-directory* (cond-expand (unix "./") (else #f)))
     29(define *egg* (egg-name *args*))
    3530
    3631;no -disable-interrupts or -no-lambda-info
    3732(define *csc-options* "-inline-global -local -inline \
    3833  -specialize -optimize-leaf-routines -clustering -lfa2 \
    39   -no-trace -unsafe")
     34  -no-trace -unsafe \
     35  -strict-types")
    4036
    41 (define (run-test-evaluated test-name test-source)
    42   (format #t "*** ~A - csi ***~%" test-name)
    43   (system (string-append "csi -s " test-source)) )
     37(define *test-files-rx* (irregex '(: (+ graph) #\- "test" #\. "scm")))
     38(define (test-filename name) (string-append name "-test"))
     39(define (test-files) (find-files "." #:test *test-files-rx* #:limit 1))
    4440
    45 (define (run-test-compiled test-name test-source csc-options)
    46   (format #t "*** ~A - csc ~A ***~%" test-name csc-options)
     41(define (ensure-test-source-name name)
     42  (if (irregex-match? *test-files-rx* name)
     43    name
     44    (make-pathname *current-directory* (test-filename name) "scm") ) )
     45
     46(define (run-test-evaluated source)
     47  (format #t "*** ~A - csi ***~%" (pathname-file source))
     48  (system (string-append "csi -s " source)) )
     49
     50(define (run-test-compiled source csc-options)
     51  (format #t "*** ~A - csc ~A ***~%" (pathname-file source) csc-options)
    4752  ;csc output is in current directory
    48   (system (string-append "csc" " " csc-options " " test-source))
    49   (system (make-pathname *current-directory* (test-filename test-name))) )
     53  (system (string-append "csc" " " csc-options " " source))
     54  (system (pathname-replace-directory (pathname-strip-extension source) *current-directory*)) )
    5055
    5156;;;
    5257
    53 (define (run-test #!optional (test-name *egg*) (csc-options *csc-options*))
    54   (let ((test-source (make-pathname #f (test-filename test-name) "scm")))
    55     (run-test-evaluated test-name test-source)
     58(define (run-test #!optional (name *egg*) (csc-options *csc-options*))
     59  (let (
     60    (source (ensure-test-source-name name)) )
     61    (unless (file-exists? source)
     62      (error 'run "no such file" source) )
     63    (run-test-evaluated source)
    5664    (newline)
    57     (run-test-compiled test-name test-source csc-options) ) )
     65    (run-test-compiled source csc-options) ) )
    5866
    59 (define (run-tests #!optional (test-names *tests*) (csc-options *csc-options*))
    60   (for-each (cut run-test <> csc-options) test-names) )
     67(define (run-tests #!optional (tests (test-files)) (csc-options *csc-options*))
     68  (for-each (cut run-test <> csc-options) tests) )
    6169
    6270;;; Do Test
Note: See TracChangeset for help on using the changeset viewer.