Changeset 15816 in project

Timestamp:

09/09/09 10:09:01 (10 years ago)

Author:

Kon Lovett

Message:

Begin of "module" (actually loaded .so) introspection. Reminder about 'normalize-pathname' problem with absolute pathnames.

Location:

chicken/trunk

Files:

• chicken.h (modified) (1 diff)
• files.scm (modified) (2 diffs)
• library.scm (modified) (1 diff)
• runtime.c (modified) (1 diff)

chicken/trunk/chicken.h

@@ -1450 +1450 @@
 C_fctexport C_word C_dbg_hook(C_word x);
 
+C_fctexport void C_loaded_modules( C_word c, C_word closure, C_word k ) C_noret;
+C_fctexport void C_module_procedures( C_word c, C_word closure, C_word k, C_char *modnam ) C_noret;
+
 C_fctimport void C_ccall C_toplevel(C_word c, C_word self, C_word k) C_noret;
 C_fctexport void C_ccall C_stop_timer(C_word c, C_word closure, C_word k) C_noret;

chicken/trunk/files.scm

@@ -362 +362 @@
         (get-environment-variable get-environment-variable)
         (reverse reverse)
-        (display display))
-    (lambda (path #!optional (platform (if (memq (build-platform) '(msvc mingw32)) 'windows 'unix)))
+        (display display)
+        (bldplt (if (memq (build-platform) '(msvc mingw32)) 'windows 'unix)) )
+    (define (addpart part parts)
+      (cond ((string=? "." part)        parts )
+            ((string=? ".." part)       (if (null? parts) '("..") (cdr parts)) )
+            (else                       (cons part parts) ) ) )
+    (lambda (path #!optional (platform bldplt))
       (let ((sep (if (eq? platform 'windows) #\\ #\/)))
-        (define (addpart part parts)
-          (cond ((string=? "." part) parts)
-                ((string=? ".." part) 
-                 (if (null? parts)
-                     '("..")
-                     (cdr parts)))
-                (else (cons part parts))))
         (##sys#check-string path 'normalize-pathname)
+
+        ;(absolute-pathname-root path)
+
         (let ((len (##sys#size path))
               (abspath #f)
@@ -412 +413 @@
                    (set! drive (##sys#substring path 0 (fx+ i 1)))
                    (loop (fx+ i 1) (fx+ i 1) '()))
-                  (else (loop (fx+ i 1) prev parts)))))))))
+                  (else (loop (fx+ i 1) prev parts)) ) ) ) ) ) ) )
 
 

chicken/trunk/library.scm

@@ -214 +214 @@
 (define-foreign-variable main_argv c-pointer "C_main_argv")
 (define-foreign-variable strerror c-string "strerror(errno)")
+
+(define ##sys#loaded-modules (##core#primitive "C_loaded_modules"))
+(define ##sys#module-procedures (##core#primitive "C_module_procedures"))
 
 (define (set-gc-report! flag) (##core#inline "C_set_gc_report" flag))

chicken/trunk/runtime.c

@@ -1913 +1913 @@
 
 
+void C_ccall
+C_loaded_modules( C_word c, C_word closure, C_word k )
+{
+  LF_LIST *np;
+  C_word mods = C_SCHEME_END_OF_LIST;
+  for( np = lf_list; np; np = np->next ) {
+    if( np->module_name ) {
+      C_word str = C_string( C_heaptop, strlen( np->module_name ), np->module_name );
+      mods = C_pair( C_heaptop, str, mods );
+    }
+  }
+  C_kontinue( k, mods );
+}
+
+
+void C_ccall
+C_module_procedures( C_word c, C_word closure, C_word k, C_char *modnam )
+{
+  LF_LIST *mod;
+  C_word prcs = C_SCHEME_END_OF_LIST;
+#if 0
+  for( mod = find_module_handle( XXX( modnam ) ) ; mod; mod = mod->next ) {
+    C_PTABLE_ENTRY *pt = mod->ptable;
+    if( pt ) {
+      for( ; pt->id; ++pt ) {
+        C_word str = C_string( C_heaptop, strlen( pt->id ), pt->id );
+        prcs = C_pair( C_heaptop, str, prcs );
+      }
+    }
+  }
+#endif
+  C_kontinue( k, prcs );
+}
+
+
 void C_unregister_lf(void *handle)
 {