* Applying non-procedure library variables no longer segfaults.

src/ikarus.compiler.ss

@@ -1934,7 +1934,7 @@
      (error 'compile "cannot find location of primitive ~s" op)]))
 
 (define (primref-loc op)
-  (mem (fx- disp-symbol-record-value record-tag) 
+  (mem (fx- disp-symbol-record-proc record-tag) 
        (obj (primref->symbol op))))
 
 

src/ikarus.syntax.ss

@@ -2193,8 +2193,8 @@
                     (let ([invoke-body (if (and (null? init*) (null? lex*))
                                            (build-void)
                                            (build-sequence no-source
-                                             (append
+                                             (cons
-                                               (map build-export lex*)
+                                               (build-exports lex*)
                                                (chi-expr* init* r mr))))])
                       (unseal-rib! rib)
                       (let ([export-subst (make-export-subst exp-int* exp-ext* rib)])
@@ -2296,7 +2296,33 @@
     (lambda (x)
       ;;; exports use the same gensym
       `(begin
-         (#%$set-symbol-value! ',x ,x))))
+         (#%$set-symbol-value! ',x ,x)
+         (#%$set-symbol-proc! ',x 
+           (if (#%procedure? ,x) ,x 
+               (case-lambda 
+                 [,(gensym) 
+                  (#%error 'apply '"~s is not a procedure" 
+                   (#%$symbol-value ',x))]))))))
+  (define build-exports
+    (lambda (ls) 
+      (define f (gensym))
+      (define name (gensym))
+      (define val (gensym))
+      `((case-lambda 
+          [(,f) 
+           (begin '#f
+             ,@(map (lambda (x) `(,f ',x ,x)) ls))])
+        (case-lambda
+          [(,name ,val) 
+           (begin
+             (#%$set-symbol-value! ,name ,val)
+             (#%$set-symbol-proc! ,name 
+               (if (#%procedure? ,val) ,val 
+                   (case-lambda 
+                     [,(gensym) 
+                      (#%error 'apply '"~s is not a procedure" 
+                       (#%$symbol-value ,name))]))))]))))
+               
   (define (make-export-subst int* ext* rib)
     (map
       (lambda (int ext)

src/libaltcogen.ss

@@ -357,7 +357,7 @@
                       (make-object
                         (primref->symbol 
                           'do-overflow)))
-                    (make-constant (- disp-symbol-record-value symbol-ptag))))
+                    (make-constant (- disp-symbol-record-proc symbol-ptag))))
            (list size)))))
   ;;; impose value
   (define (V d x)

src/pass-specify-rep.ss

@@ -415,7 +415,7 @@
            (lambda (sym)
              (record-symbol-call! sym)
              (prm 'mref (T (K sym))
-                  (K (- disp-symbol-record-value symbol-ptag))))]
+                  (K (- disp-symbol-record-proc symbol-ptag))))]
           [else (nonproc x)])]
        [(primref op) (V x)]
        [else (nonproc x)]))
@@ -458,57 +458,12 @@
           free*)]
       [else (error 'specify-rep "invalid clambda ~s" x)]))
   ;;;
-  (define (error-codes)
-    (define (code-list symbol)
-      (define L1 (gensym))
-      (define L2 (gensym))
-      `(0
-        [movl (disp ,(- disp-symbol-record-value symbol-ptag) (obj ,symbol)) ,cp-register]
-        [andl ,closure-mask ,cp-register]
-        [cmpl ,closure-tag ,cp-register]
-        [jne (label ,L1)]
-        [movl (disp ,(- disp-symbol-record-value symbol-ptag) (obj ,symbol)) ,cp-register]
-        [movl ,cp-register (disp ,(- disp-symbol-record-value symbol-ptag) (obj ,symbol))]
-        [jmp (disp ,(- disp-closure-code closure-tag) ,cp-register)]
-        [label ,L1]
-        [movl (disp ,(- disp-symbol-record-value symbol-ptag) (obj ,symbol)) %eax]
-        [cmpl ,unbound %eax]
-        [je (label ,L2)]
-        [movl (obj apply) (disp -4 %esp)]
-        [movl (obj "~s is not a procedure") (disp -8 %esp)]
-        [movl %eax (disp -12 %esp)]
-        [movl (obj ,(primref->symbol 'error)) ,cp-register]
-        [movl (disp ,(- disp-symbol-record-value symbol-ptag)
-                    ,cp-register) ,cp-register]
-        [movl ,(argc-convention 3) %eax]
-        [jmp (disp ,(- disp-closure-code closure-tag) ,cp-register)]
-        [label ,L2]
-        [movl (obj ,symbol) (disp -4 %esp)]
-        [movl (obj ,(primref->symbol 'top-level-value)) ,cp-register]
-        [movl (disp ,(- disp-symbol-record-value symbol-ptag)
-                    ,cp-register) ,cp-register]
-        [movl ,(argc-convention 1) %eax]
-        [jmp (disp ,(- disp-closure-code closure-tag) ,cp-register)]))
-    (let ([ls encountered-symbol-calls])
-      (let ([c* (map code-list ls)])
-        (let ([c* (assemble-sources (lambda (x) #f) c*)])
-          (let ([p* (map (lambda (x) ($code->closure x)) c*)])
-            (let f ([ls ls] [p* p*])
-              (cond
-                [(null? ls) (prm 'nop)]
-                [else 
-                 (make-seq
-                   (with-tmp ([p (V (K (car p*)))] [s (V (K (car ls)))])
-                     (E (prm '$init-symbol-function! s p)))
-                   (f (cdr ls) (cdr p*)))])))))))
   (define (Program x)
     (record-case x 
       [(codes code* body)
        (let ([code* (map Clambda code*)]
              [body (V body)])
-         (make-codes code*
+         (make-codes code* body))]
-           ;(make-seq (error-codes) body)
-           body))]
       [else (error 'specify-rep "invalid program ~s" x)]))
 
   (define (specify-representation x)