Changeset 16080 in project


Ignore:
Timestamp:
09/25/09 04:43:01 (10 years ago)
Author:
Kon Lovett
Message:

Rmvd use of sys ns. Simplification.

Location:
release/4/srfi-102/trunk
Files:
1 added
1 deleted
3 edited

Legend:

Unmodified
Added
Removed
  • release/4/srfi-102/trunk/procedure-introspection.scm

    r16073 r16080  
    55  (;export
    66    ;;
     7    procedure-lambda-info
    78    procedure-name
    89    procedure-arity
     
    2324
    2425  (import scheme
    25           chicken)
    26 
    27   (include "_sys-pi-api")
     26          chicken
     27          (only data-structures identity)
     28          (only posix set-file-position!)
     29          (only srfi-1 any every))
     30
     31  (require-library srfi-1 data-structures posix)
    2832
    2933;;;
    3034
     35; count of top-level pairs
     36;
     37; > 0 : proper-list length
     38; < 0 : circular-list length
     39; #.0 : dotted-list length
     40
     41(define (length.+ ls)
     42  (if (null? ls) 0
     43      (let loop ((ls (cdr ls)) (seen ls) (len 1))
     44        (cond ((null? ls)       len )
     45              ((not (pair? ls)) (exact->inexact len) )
     46              ((eq? ls seen)    (- len) )
     47              (else
     48                (loop (cdr ls) (cdr seen) (fx+ len 1)) ) ) ) ) )
     49
     50;;
     51
     52(define (update-lambda-decoration proc pred decr)
     53  (define (setter proc i) (##sys#setslot proc i (decr (##sys#slot proc i))) proc)
     54  (##sys#decorate-lambda proc pred setter) )
     55
     56(define (decode-lambda-info lambdainfo)
     57  (read (open-input-string (##sys#lambda-info->string lambdainfo))) )
     58
     59(define (encode-lambda-info info)
     60  (##sys#make-lambda-info
     61    (let ((o (open-output-string)))
     62      (write info o)
     63      (get-output-string o))) )
     64
     65;;
     66
     67(define ((tagged-lambda-decoration-predicate tag) obj)
     68  (and (pair? obj)
     69       (eq? tag (car obj))) )
     70
     71(define ((tagged-lambda-decoration-setter tag pred) proc obj)
     72  (update-lambda-decoration proc pred (lambda (obj) (cons tag obj))) )
     73
     74(define ((lambda-decoration-getter pred) proc) (##sys#lambda-decoration proc pred))
     75
     76;;
     77
     78(define (##sys#arity-at-least? obj) (and (inexact? obj) (<= 0 obj)))
     79
     80(define (lambda-info-arity-object lambdainfo)
     81  (define (lambda-info-arity-object info)
     82    ; info should never be a circular list
     83    (if (pair? info) (length.+ (cdr info))
     84         ; nothing but a name - assume 0
     85         0 ) )
     86  (and lambdainfo
     87       (lambda-info-arity-object (decode-lambda-info lambdainfo))) )
     88
     89(define (procedure-lambda-info-arity proc)
     90  (lambda-info-arity-object (##sys#lambda-info proc)) )
     91
     92(define lambda-infos)
     93(define lambda-infos-set!)
     94(let ((+lambda-infos-tag+ '#(lambda-infos)))
     95  (define lambda-infos? (tagged-lambda-decoration-predicate +lambda-infos-tag+))
     96  (set! lambda-infos-set! (tagged-lambda-decoration-setter +lambda-infos-tag+ lambda-infos?))
     97  (set! lambda-infos (lambda-decoration-getter lambda-infos?)) )
     98
     99(define (make-lambda-infos ls) (map encode-lambda-info ls))
     100(define lambda-infos-list cdr)
     101
     102(define (procedure-lambda-infos proc)
     103  (and-let* ((info (lambda-infos proc)))
     104    (lambda-infos-list info) ) )
     105
     106(define (procedure-lambda-infos-arities proc)
     107  (and-let* ((infos (procedure-lambda-infos proc)))
     108    (map lambda-info-arity-object infos) ) )
     109
     110;;
     111
     112(define docstring-info)
     113(define docstring-info-set!)
     114(let ((+docstring-info-tag+ '#(docstring)))
     115  (define docstring-info? (tagged-lambda-decoration-predicate +docstring-info-tag+))
     116  (set! docstring-info-set! (tagged-lambda-decoration-setter +docstring-info-tag+ docstring-info?))
     117  (set! docstring-info (lambda-decoration-getter docstring-info?)) )
     118
     119(define make-docstring-info identity)
     120(define docstring-info-string cdr)
     121
     122;;
     123
     124(define source-info)
     125(define source-info-set!)
     126(let ((+source-info-tag+ '#(source-info)))
     127  (define source-info? (tagged-lambda-decoration-predicate +source-info-tag+))
     128  (set! source-info-set! (tagged-lambda-decoration-setter +source-info-tag+ source-info?))
     129  (set! source-info (lambda-decoration-getter source-info?)) )
     130
     131(define make-source-info cons)
     132(define source-info-file cadr)
     133(define source-info-position cddr)
     134
     135;;
     136
     137(define (##sys#procedure-arity proc)
     138  (or (procedure-lambda-infos-arities proc)
     139      (procedure-lambda-info-arity proc) ) )
     140
     141(define (##sys#procedure-name proc)
     142  (and-let* ((info (decode-lambda-info (##sys#lambda-info proc))))
     143    (if (pair? info) (car info)
     144        info ) ) )
     145
     146(define (##sys#procedure-docstring proc)
     147  (and-let* ((info (docstring-info proc)))
     148    (docstring-info-string info) ) )
     149
     150(define (##sys#procedure-source-file proc)
     151  (and-let* ((info (source-info proc)))
     152    (source-info-file info) ) )
     153
     154(define (##sys#procedure-source-position proc)
     155  (and-let* ((info (source-info proc)))
     156    (source-info-position info) ) )
     157   
     158;sort-of
     159(define (##sys#procedure-expression proc)
     160  (and-let* ((info (source-info proc)))
     161    (let ((inp (open-input-file (source-info-file info) #:text)))
     162      (set-file-position! inp (source-info-position info))
     163      (let ((exp (read inp)))
     164        (close-input-port inp)
     165        exp ) ) ) )
     166
     167(define (##sys#procedure-environment proc)
     168  #f )
     169
     170(define (##sys#procedure-signature proc)
     171  #f )
     172
     173(define (##sys#procedure-metadata proc key)
     174  (let* ((pred (tagged-lambda-decoration-predicate key))
     175         (getter (lambda-decoration-getter pred)) )
     176    (and-let* ((pare (lambda-decoration-getter pred)))
     177      (cdr pare) ) ) )
     178
     179(define (##sys#procedure-metadata-set! proc key value)
     180  (let* ((pred (tagged-lambda-decoration-predicate key))
     181         (setter (tagged-lambda-decoration-setter key pred)) )
     182    (setter (cons key value)) ) )
     183
     184;;
     185
     186(define-constant ARGUMENT-COUNT-LIMIT 100000)
     187
     188(define (##sys#check-arity k loc)
     189  (##sys#check-range k 0 ARGUMENT-COUNT-LIMIT loc) )
     190
     191(define (##sys#check-arity-at-least obj loc)
     192  (unless (##sys#arity-at-least? obj)
     193    (##sys#signal-hook #:type-error loc "bad argument type - not an arity-at-least" obj)) )
     194
     195;;;
     196
    31197(define (->boolean obj) (and obj #t))
    32198
    33199;;;
     200
     201(define (procedure-lambda-info proc)
     202  (##sys#check-closure proc 'procedure-lambda-info)
     203  (let ((infos (procedure-lambda-infos proc)))
     204    (if infos (map decode-lambda-info infos)
     205        (and-let* ((info (##sys#lambda-info proc)))
     206          (decode-lambda-info info) ) ) ) )
    34207
    35208(define (procedure-name proc)
     
    46219(define (procedure-fixed-arity? proc)
    47220  (and-let* ((arities (##sys#procedure-arity proc)))
    48     (if (not (##sys#pair? arities)) (##sys#exact? arities)
    49         (##sys#every ##sys#exact? arities) ) ) )
     221    (if (not (pair? arities)) (##sys#exact? arities)
     222        (every ##sys#exact? arities) ) ) )
    50223
    51224(define (procedure-minimum-arity proc)
    52225  (and-let* ((arities (##sys#procedure-arity proc)))
    53     (if (not (##sys#pair? arities)) (##sys#inexact->exact arities)
    54         (apply ##sys#min (##sys#map ##sys#inexact->exact arities)) ) ) )
     226    (if (not (pair? arities)) (##sys#inexact->exact arities)
     227        (apply min (map ##sys#inexact->exact arities)) ) ) )
    55228
    56229(define arity-at-least? ##sys#arity-at-least?)
    57230
    58 (define (arity-at-least-value arity-at-least)
     231(define (arity-at-least-value k)
    59232  (##sys#check-arity-at-least 'arity-at-least-value k)
    60   (##sys#inexact->exact arity-at-least) )
     233  (##sys#inexact->exact k) )
    61234
    62235(define (procedure-arity-includes? proc k)
    63   (define (at-least-k arity-obj)
    64     (if (##sys#exact? obj) (= k arity-obj)
    65         (<= arity-obj k) ) )
     236  (define (at-least-k a) (if (##sys#exact? a) (= k a) (<= a k)))
    66237  (##sys#check-closure proc 'procedure-arity-includes?)
    67238  (##sys#check-exact k 'procedure-arity-includes?)
    68239  (##sys#check-arity k 'procedure-arity-includes?)
    69240  (let ((arities (##sys#procedure-arity proc)))
    70     (or (not arities)                     ; no arity information so assume any arity
    71         (and (not (##sys#pair? arities))  ; one arity
    72              (at-least-k arities))
    73                                           ; more than one arity
    74         (##sys#any at-least-k arities) ) ) )
     241    ; no arity information? - then so assume any arity
     242    (or (not arities)
     243        ; > one arity?
     244        (if (pair? arities) (any at-least-k arities)
     245            ; one arity
     246            (at-least-k arities) ) ) ) )
    75247
    76248(define (procedure-documentation-string proc)
  • release/4/srfi-102/trunk/srfi-102.meta

    r16075 r16080  
    1010 (files
    1111  "tests"
    12   "_sys-pi-api.scm"
    1312  "procedure-introspection.scm"
    1413  "srfi-102.scm"
  • release/4/srfi-102/trunk/srfi-102.scm

    r16072 r16080  
    1414  (import scheme chicken procedure-introspection)
    1515
     16  (require-library procedure-introspection)
     17
    1618;;;
    1719
    18 (register-feature 'srfi-102)
     20(register-feature! 'srfi-102)
    1921
    2022) ;module srfi-102
Note: See TracChangeset for help on using the changeset viewer.