Merge branch 'include-path'

egallesio · Oct 14, 2024 · f5ac37c · f5ac37c
2 parents 9270fce + adce01f
commit f5ac37c
Show file tree

Hide file tree

Showing 3 changed files with 69 additions and 31 deletions.
diff --git a/lib/compiler.stk b/lib/compiler.stk
@@ -460,19 +460,19 @@ doc>
 (define (compile-reference name env epair tail?)
   (compile-access name env epair #t))
 
-;; compile-set! will just call compile-access, and when doing so, will
+;; compile-%%set! will just call compile-access, and when doing so, will
 ;; set the 'ref' argument to #f. The 'ref' argument to compile-access
 ;; means "this is just a reference, not an assignment".
-;; Before calling compile-access, compile-set! will check the syntax
+;; Before calling compile-access, compile-%%set! will check the syntax
 ;; for set! and also extract the variable name.
 ;;
-;;     (compile-set! '(set! a (+ 2 b)))
+;;     (compile-%%set! '(set! a (+ 2 b)))
 ;;      will make these two calls:
 ;;        (compile '(+ 2 b) env '(set! a + 2 b) #f)
 ;;        (compile-access 'a env '(set! a + 2 b) #f)
 ;;
 ;; The extended set! is treated separately.
-(define (compile-set! args env tail?)
+(define (compile-%%set! args env tail?)
   (let ((len (length (cdr args))))
     (if (= len 2)
         (let ((var (cadr args))
@@ -1846,13 +1846,13 @@ doc>
     (close-port port)))
 
 
-(define (compile-include e env tail)
+(define (compile-%%include e env tail)
   (unless (every string? (cdr e))
     (compiler-error 'include e "bad include directive ~S" e))
   (for-each (lambda (f) (%include-file f #t))
             (cdr e)))
 
-(define (compile-include-ci e env tail)
+(define (compile-%%include-ci e env tail)
   (unless (every string? (cdr e))
     (compiler-error 'include-ci e "bad include directive ~S" e))
   (for-each (lambda (f) (%include-file f #f))
@@ -1870,7 +1870,7 @@ doc>
 ;;
 ;; Constants:
 ;; 0: x
-(define (compile-in-scheme e env tail)
+(define (compile-%%in-scheme e env tail)
   (if (= (length e) 2)
       (begin
         (compile (cadr e) env (cadr e) tail)
@@ -2007,7 +2007,7 @@ both forms.
 ;;;;
 ;;;; REQUIRE
 ;;;;
-(define (compile-require e env tail)
+(define (compile-%%require e env tail)
   ;; Require is not really special (it is in fact compiled as a normal call)
   ;; We just try to add the globals of the file to the list of known
   ;; globals. This is very empiric, but it avoids to add too much false
@@ -2024,7 +2024,7 @@ both forms.
 ;;;;
 ;;;; WHEN-COMPILE
 ;;;;
-(define (compile-when-compile e env tail)
+(define (compile-%%when-compile e env tail)
   (with-handler (lambda (c)
                   (eprintf "*** Exception on when-compile form of ~S\n" e)
                   (raise c))
@@ -2104,16 +2104,16 @@ both forms.
             ((with-handler)       (compile-with-handler   e env tail?))
             ((define-macro)       (compile-define-macro   e env tail?))
 
-            ((%%set!)             (compile-set!           e env tail?))
+            ((%%set!)             (compile-%%set!         e env tail?))
 
             ((%let-syntax)        (compile-%let-syntax     e env tail?))
 
             ;; Special calls
-            ((%%require)          (compile-require        e env tail?))
-            ((%%when-compile)     (compile-when-compile   e env tail?))
-            ((%%include)          (compile-include        e env tail?))
-            ((%%include-ci)       (compile-include-ci     e env tail?))
-            ((%%in-scheme)        (compile-in-scheme      e env tail?))
+            ((%%require)          (compile-%%require      e env tail?))
+            ((%%when-compile)     (compile-%%when-compile e env tail?))
+            ((%%include)          (compile-%%include      e env tail?))
+            ((%%include-ci)       (compile-%%include-ci   e env tail?))
+            ((%%in-scheme)        (compile-%%in-scheme    e env tail?))
             ((%%source-pos)       (compile-%%source-pos   e env tail?))
             ((%%label)            (compile-%%label        e env tail?))
             ((%%goto)             (compile-%%goto         e env tail?))

diff --git a/lib/load.stk b/lib/load.stk
@@ -535,10 +535,13 @@ doc>
   (let ((inc (string->symbol (format "%%~a" kind))))
     (if (null? files)
         (error kind "at least one parameter must be provided")
-        `(,inc ,@(map (lambda (x)
-                        ;; return x if find-path is null to improve messages
-                        (or (find-path x) x))
-                      files)))))
+        (let* ((src-file (current-loading-file))
+               (dir      (and src-file (dirname src-file)))
+               (paths    (if dir (cons dir *load-path*) *load-path*)))
+          `(,inc ,@(map (lambda (x)
+                          ;; return x if find-path is null to improve messages
+                          (or (find-path x paths) x))
+                      files))))))
 
 (define-macro (include . files)
   `(%do-include include ,files))

diff --git a/src/boot.c b/src/boot.c
@@ -598,7 +598,7 @@ char* STk_boot_consts = "#("
 "compile-reference" " "
 "\"~S is a bad symbol\"" " "
 "\"bad assignment syntax in ~S\"" " "
-"compile-set!" " "
+"compile-%%set!" " "
 "\"bad syntax in ~S\"" " "
 "compile-if" " "
 "extended-lambda->lambda" " "
@@ -807,13 +807,13 @@ char* STk_boot_consts = "#("
 "close-port" " "
 "include" " "
 "\"bad include directive ~S\"" " "
-"compile-include" " "
+"compile-%%include" " "
 "include-ci" " "
 "\"bad include directive ~S\"" " "
-"compile-include-ci" " "
+"compile-%%include-ci" " "
 "INSCHEME" " "
 "\"expected one argument\"" " "
-"compile-in-scheme" " "
+"compile-%%in-scheme" " "
 "%let-syntax" " "
 "\"ill formed %let-syntax ~S\"" " "
 "\"ill formed binding ~S\"" " "
@@ -830,9 +830,9 @@ char* STk_boot_consts = "#("
 "find-file-information" " "
 "import-file-information" " "
 "boolean?" " "
-"compile-require" " "
+"compile-%%require" " "
 "\"*** Exception on when-compile form of ~S\\n\"" " "
-"compile-when-compile" " "
+"compile-%%when-compile" " "
 "(lambda body `(begin (%%when-compile ,@body) (void)))" " "
 "when-load-and-compile" " "
 "(lambda body `(begin (%%when-compile ,@body) ,@body (void)))" " "
@@ -1837,7 +1837,7 @@ char* STk_boot_consts = "#("
 "(lambda (file) `(%%require4syntax ,file))" " "
 "%%require4syntax" " "
 "%do-include" " "
-"(lambda (kind files) (let ((inc (string->symbol (format \"%%~a\" kind)))) (if (null? files) (error kind \"at least one parameter must be provided\") `(,inc ,@(map (lambda (x) (or (find-path x) x)) files)))))" " "
+"(lambda (kind files) (let ((inc (string->symbol (format \"%%~a\" kind)))) (if (null? files) (error kind \"at least one parameter must be provided\") (let* ((src-file (current-loading-file)) (dir (and src-file (dirname src-file))) (paths (if dir (cons dir *load-path*) *load-path*))) `(,inc ,@(map (lambda (x) (or (find-path x paths) x)) files))))))" " "
 "\"%%~a\"" " "
 "\"at least one parameter must be provided\"" " "
 "(lambda files `(%do-include include ,files))" " "
@@ -23041,7 +23041,7 @@ STk_instr STk_boot_code [] = {
 0xa,
 0x7d,
 0x2d,
-0x6771,
+0x6794,
 0x25,
 0x55,
 0xf6,
@@ -48411,7 +48411,7 @@ STk_instr STk_boot_code [] = {
 0x55,
 0x726,
 0x23,
-0x37,
+0x5a,
 0x2,
 0x25,
 0x25,
@@ -48442,16 +48442,50 @@ STk_instr STk_boot_code [] = {
 0x4c,
 0x2,
 0x24,
+0x2a,
+0x3,
+0x25,
+0x56,
+0x6fe,
+0x0,
+0x15,
+0xc,
+0x1d,
+0x7,
+0x25,
 0x65,
+0x56,
+0x1d6,
+0x1,
+0x1c,
+0x1,
+0x1,
+0x16,
+0xd,
+0x1d,
+0x6,
+0x66,
+0xa,
+0x6ec,
+0x3b,
+0x1c,
+0x2,
+0xa,
+0x6ec,
+0x17,
+0x75,
+0x100,
 0x25,
 0x23,
-0xd,
+0xf,
 0x1,
 0x25,
 0x65,
+0x75,
+0x102,
 0x56,
 0x332,
-0x1,
+0x2,
 0x1e,
 0x4,
 0xc,
@@ -48461,12 +48495,13 @@ STk_instr STk_boot_code [] = {
 0x24,
 0x21,
 0x75,
-0x100,
+0x200,
 0x56,
 0x3a,
 0x2,
 0x3b,
 0x24,
+0x24,
 0x21,
 0x55,
 0xf6,