Changeset 15823 in project


Ignore:
Timestamp:
09/11/09 05:10:24 (10 years ago)
Author:
kon
Message:

More work on loaded library introspection

Location:
chicken/trunk
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • chicken/trunk/chicken.h

    r15819 r15823  
    15141514C_fctexport void C_ccall C_call_with_cthulhu(C_word c, C_word self, C_word k, C_word proc) C_noret;
    15151515C_fctexport void C_ccall C_copy_closure(C_word c, C_word closure, C_word k, C_word proc) C_noret;
    1516 C_fctexport void C_loaded_libraries( C_word c, C_word closure, C_word k ) C_noret;
    1517 C_fctexport void C_library_procedures( C_word c, C_word closure, C_word k, C_word modnam ) C_noret;
     1516C_fctexport void C_literal_frame_info( C_word c, C_word closure, C_word k ) C_noret;
     1517C_fctexport void C_literal_frame_toplevel( C_word c, C_word closure, C_word k, C_word modnam ) C_noret;
     1518C_fctexport void C_literal_frame_ptable( C_word c, C_word closure, C_word k, C_word modnam, C_word inclptrs ) C_noret;
    15181519
    15191520#if !defined(__GNUC__) && !defined(__INTEL_COMPILER)
  • chicken/trunk/eval.scm

    r15773 r15823  
    2828(declare
    2929  (unit eval)
    30   (uses expand)
     30  (uses expand data-structures)
    3131  (disable-warning var)
    32   (hide ##sys#split-at-separator
    33         ##sys#r4rs-environment ##sys#r5rs-environment
     32  (hide ##sys#r4rs-environment ##sys#r5rs-environment
    3433        ##sys#interaction-environment pds pdss pxss)
    3534  (not inline ##sys#repl-eval-hook ##sys#repl-read-hook ##sys#repl-print-hook
     
    10611060(define load-library ##sys#load-library)
    10621061
    1063 (define ##sys#split-at-separator
    1064   (let ([reverse reverse] )
    1065     (lambda (str sep)
    1066       (let ([len (##sys#size str)])
    1067         (let loop ([items '()] [i 0] [j 0])
    1068           (cond [(fx>= i len)
    1069                  (reverse (cons (##sys#substring str j len) items)) ]
    1070                 [(char=? (##core#inline "C_subchar" str i) sep)
    1071                  (let ([i2 (fx+ i 1)])
    1072                    (loop (cons (##sys#substring str j i) items) i2 i2) ) ]
    1073                 [else (loop items (fx+ i 1) j)] ) ) ) ) ) )
     1062;; (loaded-libraries [COMBINE-ENTRIES?] [INCLUDE-SYSTEM-ENTRIES?])
     1063;; COMBINE-ENTRIES? : a boolean, collapse all literal-frame entries for the
     1064;; same library into a single entry, the default is #t.
     1065;; INCLUDE-SYSTEM-ENTRIES? : a boolean, include entries for system libraries, the
     1066;; default is #f.
     1067;; => ((<pathname> <literal-frame-count> <ptable?>)...)
     1068;; where <pathname> is #f (when runtime) or a string,
     1069;; <literal-frame-count> is the total of entrypoints (toplevel),
     1070;; and <ptable?> is a boolean indicating whether the lf has a ptable.
     1071
     1072(define (loaded-libraries #!optional (cmb? #t) (sys? #f))
     1073  (let ((ls (##sys#literal-frame-info)))
     1074    ; Everything wanted?
     1075    (if (and (not cmb?) sys?)
     1076        ; then everything it is
     1077        ls
     1078        ; else perform a "cull
     1079        (let loop ((ils ls) (ols '()))
     1080          (if (null? ils)
     1081              ols
     1082              (let* ((cur (car ils))
     1083                     (nxt (cdr ils))
     1084                     (nam (car cur))
     1085                     ; Is this a wanted system entry or not a system entry?
     1086                     (cur (and (or sys? (and nam (not (member nam (dynamic-load-libraries)))))
     1087                               cur)) )
     1088                (cond ((not cur)
     1089                        (loop nxt ols) )
     1090                      ; Combining entries?
     1091                      (cmb?
     1092                        (let ((ext (alist-ref nam ols equal?)))
     1093                          (if ext
     1094                             (begin
     1095                               ; Accumulate frame count
     1096                               (set-car! ext (+ (car ext) (cadr cur)))
     1097                               ; Has any ptable then has a ptable
     1098                               (when (and (not (cadr ext)) (caddr cur))
     1099                                 (set-car! (cdr ext) #t) )
     1100                               (loop nxt ols) )
     1101                             (loop nxt (cons cur ols)) ) ) )
     1102                      (else
     1103                        (loop nxt (cons cur ols)) ) ) ) ) ) ) ) )
     1104
     1105(define (loaded-library-toplevel nam)
     1106 (when nam (##sys#check-string nam 'loaded-library-toplevel))
     1107 (##sys#literal-frame-toplevel (and nam (##sys#make-c-string nam))) )
     1108
     1109(define (loaded-library-ptable nam #!optional ptrs?)
     1110 (when nam (##sys#check-string nam 'loaded-library-ptable))
     1111 (##sys#literal-frame-ptable (and nam (##sys#make-c-string nam)) ptrs?) )
    10741112
    10751113
  • chicken/trunk/library.scm

    r15819 r15823  
    252252(define ##sys#copy-closure (##core#primitive "C_copy_closure"))
    253253(define ##sys#apply-argument-limit (##sys#fudge 34))
    254 (define ##sys#loaded-libraries (##core#primitive "C_loaded_libraries"))
    255 (define ##sys#library-procedures (##core#primitive "C_library_procedures"))
    256254
    257255(define (##sys#block-set! x i y)
     
    366364
    367365;;; Dynamic Load
     366
     367(define ##sys#literal-frame-info (##core#primitive "C_literal_frame_info"))
     368(define ##sys#literal-frame-toplevel (##core#primitive "C_literal_frame_toplevel"))
     369(define ##sys#literal-frame-ptable (##core#primitive "C_literal_frame_ptable"))
    368370
    369371(define ##sys#dload (##core#primitive "C_dload"))
  • chicken/trunk/runtime.c

    r15819 r15823  
    19291929
    19301930void C_ccall
    1931 C_loaded_libraries( C_word c, C_word closure, C_word k )
     1931C_literal_frame_info( C_word c, C_word closure, C_word k )
    19321932{
    19331933  LF_LIST *np;
     
    19351935
    19361936  for( np = lf_list; np; np = np->next ) {
    1937     if( np->module_name ) {
    1938       C_word str = C_string( C_heaptop, strlen( np->module_name ), np->module_name );
    1939       mods = C_pair( C_heaptop, str, mods );
    1940     }
     1937    C_word str = C_string2( C_heaptop, np->module_name );
     1938    C_word ent = C_h_list( 3, str, C_fix( np->count ), C_mk_bool( np->ptable ) );
     1939    /*assert( np->lf ? np->count : 1 );*/
     1940    mods = C_h_pair( ent, mods );
    19411941  }
    19421942
     
    19461946
    19471947void C_ccall
    1948 C_library_procedures( C_word c, C_word closure, C_word k, C_word modnam )
     1948C_literal_frame_toplevel( C_word c, C_word closure, C_word k, C_word modnam )
    19491949{
    19501950  LF_LIST *np;
     
    19531953  if( c != 3 ) C_bad_argc( c, 3 );
    19541954
    1955   if( C_immediatep( modnam ) || C_STRING_TYPE != C_header_bits( modnam )  )
    1956     barf( C_BAD_ARGUMENT_TYPE_ERROR, "library-procedures", modnam );
    1957 
    1958   for( np = find_module_handle( C_c_string( modnam ) ) ; np; np = np->next ) {
    1959     C_PTABLE_ENTRY *pt = np->ptable;
    1960     if( pt ) {
    1961       for( ; pt->id; ++pt ) {
    1962         C_word str = C_string( C_heaptop, strlen( pt->id ), pt->id );
    1963         prcs = C_pair( C_heaptop, str, prcs );
     1955  if( (C_immediatep( modnam ) && C_SCHEME_FALSE != modnam)
     1956      || (!C_immediatep( modnam ) && C_STRING_TYPE != C_header_bits( modnam ))  )
     1957    barf( C_BAD_ARGUMENT_TYPE_ERROR, "##sys#literal-frame-toplevel", modnam );
     1958
     1959  for( np = lf_list; np; np = np->next ) {
     1960    if( (C_SCHEME_FALSE == modnam && !np->module_name)
     1961        || (C_SCHEME_FALSE != modnam
     1962            && np->module_name && !strcmp( np->module_name, C_c_string( modnam ) )) ) {
     1963      C_word *lf = np->lf;
     1964      if( lf ) {
     1965        int cnt = np->count;
     1966        /*assert( np->count );*/
     1967        for( ; cnt--; ++lf ) {
     1968          prcs = C_h_pair( *lf, prcs );
     1969        }
     1970      }
     1971    }
     1972  }
     1973printf( "\n" );
     1974
     1975  C_kontinue( k, prcs );
     1976}
     1977
     1978
     1979void C_ccall
     1980C_literal_frame_ptable( C_word c, C_word closure, C_word k, C_word modnam, C_word inclptrs )
     1981{
     1982  LF_LIST *np;
     1983  C_word prcs = C_SCHEME_END_OF_LIST;
     1984
     1985  if( c != 4 ) C_bad_argc( c, 4 );
     1986
     1987  if( (C_immediatep( modnam ) && C_SCHEME_FALSE != modnam)
     1988      || (!C_immediatep( modnam ) && C_STRING_TYPE != C_header_bits( modnam ))  )
     1989    barf( C_BAD_ARGUMENT_TYPE_ERROR, "##sys#literal-frame-ptable", modnam );
     1990
     1991  for( np = lf_list; np; np = np->next ) {
     1992    if( (C_SCHEME_FALSE == modnam && !np->module_name)
     1993        || (C_SCHEME_FALSE != modnam
     1994            && np->module_name && !strcmp( np->module_name, C_c_string( modnam ) )) ) {
     1995      C_PTABLE_ENTRY *pt = np->ptable;
     1996      if( pt ) {
     1997        for( ; pt->id; ++pt ) {
     1998          C_word str = C_string2( C_heaptop, pt->id );
     1999          C_word ent = str;
     2000          if( C_truep( inclptrs ) ) {
     2001            C_word ptr = C_mpointer( C_heaptop, pt->ptr );
     2002            ent = C_h_pair( str, ptr );
     2003          }
     2004          prcs = C_h_pair( ent, prcs );
     2005        }
    19642006      }
    19652007    }
Note: See TracChangeset for help on using the changeset viewer.