Changeset 16110 in project


Ignore:
Timestamp:
09/29/09 17:42:38 (10 years ago)
Author:
Kon Lovett
Message:

Fixed arity cache

Location:
release/4/srfi-102/trunk
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/4/srfi-102/trunk/notes.txt

    r16080 r16110  
    11
    2 #|
     2* Procedure Signature
     3
    34  ; [..] - optional
    45  ; <..> - non-terminal
     
    4647 
    4748  <case-lambda> ::  ( <lambda> ... )
    48 |#
    4949
    50 #| 
     50* MetaData (extra)
     51
    5152  <metadata>    ::  <keyword> <metadatum> <metadata>
    5253
     
    5859
    5960  <datums>      ::  <datum> <datums>
    60 |#
  • release/4/srfi-102/trunk/procedure-introspection.scm

    r16080 r16110  
    3333;;;
    3434
    35 ; count of top-level pairs
    36 ;
    37 ; > 0 : proper-list length
    38 ; < 0 : circular-list length
    39 ; #.0 : dotted-list length
     35;;
     36
     37(define (->boolean obj) (and obj #t))
     38
     39;; count of top-level pairs
     40;;
     41;; > 0 : proper-list length
     42;; < 0 : circular-list length
     43;; #.0 : dotted-list length
    4044
    4145(define (length.+ ls)
     
    4852                (loop (cdr ls) (cdr seen) (fx+ len 1)) ) ) ) ) )
    4953
    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) )
     54;; Lambda Info Coding
    5555
    5656(define (decode-lambda-info lambdainfo)
     
    6363      (get-output-string o))) )
    6464
    65 ;;
     65;; Tagged Lambda Decoration
     66
     67(define (update-lambda-decoration proc pred decr)
     68  (define (setter proc i) (##sys#setslot proc i (decr (##sys#slot proc i))) proc)
     69  (##sys#decorate-lambda proc pred setter) )
    6670
    6771(define ((tagged-lambda-decoration-predicate tag) obj)
     
    7074
    7175(define ((tagged-lambda-decoration-setter tag pred) proc obj)
    72   (update-lambda-decoration proc pred (lambda (obj) (cons tag obj))) )
     76  (update-lambda-decoration proc pred (lambda (old) (cons tag obj))) )
    7377
    7478(define ((lambda-decoration-getter pred) proc) (##sys#lambda-decoration proc pred))
    7579
    76 ;;
    77 
    78 (define (##sys#arity-at-least? obj) (and (inexact? obj) (<= 0 obj)))
     80;; Arity from lambda-info
    7981
    8082(define (lambda-info-arity-object lambdainfo)
     
    8789       (lambda-info-arity-object (decode-lambda-info lambdainfo))) )
    8890
    89 (define (procedure-lambda-info-arity proc)
     91(define (lambda-info-arity proc)
    9092  (lambda-info-arity-object (##sys#lambda-info proc)) )
    9193
     
    98100
    99101(define (make-lambda-infos ls) (map encode-lambda-info ls))
    100 (define lambda-infos-list cdr)
    101 
    102 (define (procedure-lambda-infos proc)
     102
     103(define (lambda-infos-list proc)
    103104  (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)))
     105    (cdr info) ) )
     106
     107(define (lambda-infos-arities proc)
     108  (and-let* ((infos (lambda-infos-list proc)))
    108109    (map lambda-info-arity-object infos) ) )
    109110
    110 ;;
     111;; Arity Cache
     112
     113(define lambda-arity)
     114(define lambda-arity-set!)
     115(let ((+lambda-arity-tag+ '#(lambda-arity)))
     116  (define lambda-arity? (tagged-lambda-decoration-predicate +lambda-arity-tag+))
     117  (set! lambda-arity-set! (tagged-lambda-decoration-setter +lambda-arity-tag+ lambda-arity?))
     118  (set! lambda-arity (lambda-decoration-getter lambda-arity?)) )
     119
     120(define (##sys#procedure-arity proc)
     121  (let ((arity (lambda-arity proc)))
     122    (or (and arity (cdr arity))
     123        (let ((arities (lambda-infos-arities proc)))
     124          (if arities
     125              (begin
     126                (lambda-arity-set! proc arities)
     127                arities )
     128              (and-let* ((arity (lambda-info-arity proc)))
     129                (lambda-arity-set! proc arity)
     130                arity ) ) ) ) ) )
     131
     132
     133;; Docstring
    111134
    112135(define docstring-info)
     
    120143(define docstring-info-string cdr)
    121144
    122 ;;
     145;; Source Info
    123146
    124147(define source-info)
     
    134157
    135158;;
    136 
    137 (define (##sys#procedure-arity proc)
    138   (or (procedure-lambda-infos-arities proc)
    139       (procedure-lambda-info-arity proc) ) )
    140159
    141160(define (##sys#procedure-name proc)
     
    184203;;
    185204
     205(define (##sys#arity-at-least? obj) (and (inexact? obj) (<= 0 obj)))
     206
    186207(define-constant ARGUMENT-COUNT-LIMIT 100000)
    187208
     
    195216;;;
    196217
    197 (define (->boolean obj) (and obj #t))
    198 
    199 ;;;
    200 
    201218(define (procedure-lambda-info proc)
    202219  (##sys#check-closure proc 'procedure-lambda-info)
    203   (let ((infos (procedure-lambda-infos proc)))
     220  (let ((infos (lambda-infos-list proc)))
    204221    (if infos (map decode-lambda-info infos)
    205222        (and-let* ((info (##sys#lambda-info proc)))
Note: See TracChangeset for help on using the changeset viewer.