Commit 2d07af48 authored by Erick Gallesio's avatar Erick Gallesio

.

parent ee57c5b4
2006-09-27 Erick Gallesio <eg@essi.fr>
* lib/compfile.stk:
* lib/compiler.stk
* src/fport.c
* src/vm.c: Added informations on the global variables in
compiled bytecode files. This permits to avoid false messages on
references to undefined symbols.
2006-09-26 Erick Gallesio <eg@essi.fr>
* utils/stklos-compile: Added the possibility to compile
......
......@@ -2,7 +2,7 @@
#
# Author: Erick Gallesio [eg@unice.fr]
# Creation date: 11-Apr-2000 10:30 (eg)
# Last file update: 26-Sep-2006 19:51 (eg)
# Last file update: 27-Sep-2006 14:02 (eg)
SUBDIRS = Match.d SILex.d Lalr.d @LURCDIR@
......@@ -130,7 +130,7 @@ boot: ../src/boot.img
cp ./boot.img3 ../src/boot.img; \
cp ./instr3 ../src/vm-instr.h; \
echo "*** Create new boot.c"; \
../src/stklos -c -b ../src/boot.img \
../src/stklos -q -c -b ../src/boot.img \
-f make-C-boot.stk -- boot.img3 ../src/boot.c; \
echo "*** Recompile STklos"; \
(cd ../src; make stklos); \
......@@ -141,6 +141,9 @@ boot: ../src/boot.img
exit 1; \
fi
# Compile SRFI13 before SRFI14 to avoid 2 warnings
srfi-13.ostk: srfi-14.ostk
doc: $(DOCDB)
$(DOCDB): $(scheme_SRCS) $(scheme_BOOT)
......
......@@ -18,7 +18,7 @@
#
# Author: Erick Gallesio [eg@unice.fr]
# Creation date: 11-Apr-2000 10:30 (eg)
# Last file update: 26-Sep-2006 19:51 (eg)
# Last file update: 27-Sep-2006 14:02 (eg)
srcdir = @srcdir@
top_srcdir = @top_srcdir@
......@@ -637,7 +637,7 @@ boot: ../src/boot.img
cp ./boot.img3 ../src/boot.img; \
cp ./instr3 ../src/vm-instr.h; \
echo "*** Create new boot.c"; \
../src/stklos -c -b ../src/boot.img \
../src/stklos -q -c -b ../src/boot.img \
-f make-C-boot.stk -- boot.img3 ../src/boot.c; \
echo "*** Recompile STklos"; \
(cd ../src; make stklos); \
......@@ -648,6 +648,9 @@ boot: ../src/boot.img
exit 1; \
fi
# Compile SRFI13 before SRFI14 to avoid 2 warnings
srfi-13.ostk: srfi-14.ostk
doc: $(DOCDB)
$(DOCDB): $(scheme_SRCS) $(scheme_BOOT)
......
;;;;
;;;; compfile.stk -- STklos File Compiler
;;;;
;;;; Copyright © 2001-2005 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;; Copyright 2001-2006 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
......@@ -21,15 +21,28 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 17-Mar-2001 12:11 (eg)
;;;; Last file update: 29-Apr-2005 18:12 (eg)
;;;; Last file update: 27-Sep-2006 10:03 (eg)
;;;;
(define (compile-file input output)
(let* ((in (open-input-file input)) ;; FIXME: A VIRER ne sert plus
(out (open-output-file output))
(tm (clock))
(copts *compiler-options*))
(define (compute-file-informations initial-globals)
(let ((globs (let loop ((lst (compiler-known-globals))
(old initial-globals))
(cond
((null? old) lst)
((memv (car old) lst) (loop (delete (car old) lst)
(cdr old)))
(else (loop lst (cdr old)))))))
;; Return informations
(list :version (version)
:globals globs)))
(let ((out (open-output-file output))
(globs (compiler-known-globals))
(tm (clock))
(copts *compiler-options*))
;; Defer warning til the end of the compilation of file
(set! *compiler-options* (cons 'warn-use-undef-postpone *compiler-options*))
......@@ -39,16 +52,17 @@
;; Read the source file
(include-file input)
(emit 'END-OF-CODE)
;; Write the header
(format out "#!/usr/bin/env stklos-script\n")
(format out "STklos ~S ;-*-Scheme -*-\n" (version))
(format out "; A -*- Scheme -*- generated file *DO NOT EDIT**\n")
(format out "STklos ~S\n" (compute-file-informations globs))
(let ((code (assemble (reverse! *code-instr*))))
;;Write the assembly code and code vector
;;(format out "\n#|\n")
;;(disassemble-code code out)
;;(format out "\n~S\n|#\n" code)
;;(format out "\n~S\n|\#\n" code)
;; Write new constants as a vector
(format out "#~S\n" *code-constants*)
......@@ -56,8 +70,7 @@
;; Write byte-code
(%dump-code out code))
;; Close files
(close-input-port in)
;; Close file
(close-output-port out)
;; Show undefined symbols
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 26-Feb-2000 10:47 (eg)
;;;; Last file update: 26-Sep-2006 22:03 (eg)
;;;; Last file update: 27-Sep-2006 12:35 (eg)
;;;;
;;(define-module new-compiler
......@@ -175,6 +175,9 @@ doc>
*forward-globals*)
(set! *forward-globals* '()))
(define (compiler-known-globals)
*known-globals*)
(define (define->lambda l)
(if (> (length l) 2)
(let ((bind (cadr l))
......@@ -854,7 +857,7 @@ doc>
((-) (case len
((0) (compiler-error '- epair "needs at least one argument"))
((1) (if (number? (car actuals))
(compile-constant (- (car actuals)) env epair #f)
(compile-constant (- (car actuals)) env #f)
(compile-normal-call fct actuals len env epair #f)))
((2) (let ((a (car actuals))
(b (cadr actuals)))
......@@ -887,7 +890,7 @@ doc>
((/) (case len
((0) (compiler-error '/ epair "needs at least one argument"))
((1) (if (number? (car actuals))
(compile-constant (/ 1 (car actuals)) env epair #f)
(compile-constant (/ 1 (car actuals)) env #f)
(compile-normal-call fct actuals len env epair #f)))
((2) (let ((a (car actuals))
(b (cadr actuals)))
......@@ -1350,6 +1353,21 @@ doc>
;;;; Special Calls
;;;;
;;;;======================================================================
(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
;; warning when compiling a file using another one.
(when (and (= (length e) 2)
(string? (cadr e)))
(let ((infos (let ((path (find-path (cadr e))))
(if path
(%file-informations path)
'()))))
(when (pair? infos)
(for-each new-global (key-get infos :globals '())))))
(compile-normal-call (car e) (cdr e) (length e) env e tail))
(define (compile-%%label e env tail)
(if (= (length e) 2)
......@@ -1417,6 +1435,7 @@ doc>
((define-macro) (compile-define-macro e env tail?))
;; Special calls
((require) (compile-require e env tail?))
((%%include) (compile-include e env tail?))
((%%source-pos) (compile-%%source-pos e env tail?))
((%%label) (compile-%%label e env tail?))
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 14-Mar-2001 13:57 (eg)
;;;; Last file update: 5-Apr-2006 10:14 (eg)
;;;; Last file update: 27-Sep-2006 15:59 (eg)
;;;;
......@@ -30,13 +30,23 @@
(apply error 'panic (string-append "*** PANIC *** " (car l)) (cdr l)))
(define (%path-without-cwd path)
(let ((cwd (getcwd)))
(if (eq? (string-index cwd path) 0)
(substring path
(+ 1 (string-length cwd))
(string-length path))
path)))
;;; ----------------------------------------------------------------------
;;; compiler-error ...
;;; ----------------------------------------------------------------------
(define (compiler-error where who fmt . l)
(let* ((where (if (eq? where (void)) "" (format "~A: " where)))
(loc (if (%epair? who)
(format "~A:~A: " (%epair-file who) (%epair-line who))
(format "~A:~A: "
(%path-without-cwd (%epair-file who))
(%epair-line who))
"")))
(if *compiler-port*
;; Compiling a file
......@@ -55,7 +65,9 @@
(define (compiler-warning where who fmt . l)
(let* ((where (if (eq? where (void)) "" (format "~A: " where)))
(loc (if (%epair? who)
(format "~A:~A: " (%epair-file who) (%epair-line who))
(format "~A:~A: "
(%path-without-cwd (%epair-file who))
(%epair-line who))
"")))
(if (or #t *compiler-port*)
;; Compiling a file
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 17-Mar-2001 20:32 (eg)
;;;; Last file update: 26-Sep-2006 20:03 (eg)
;;;; Last file update: 27-Sep-2006 13:41 (eg)
;;;;
; ======================================================================
......@@ -173,7 +173,7 @@
(replace-2-instr code (list 'PUSH-GREF-INVOKE
(this-arg1 code)
(next-arg1 code))))
;; [PUSH-GLOBAL-REF, TAIL-INVOKE] => PUSH-GREF-TAIL-INV
((and (eq? i1 'PUSH-GLOBAL-REF) (eq? i2 'TAIL-INVOKE))
(replace-2-instr code (list 'PUSH-GREF-TAIL-INV
......
;;;;
;;;; srfi-4.stk -- Implementation of SRFI-4 (Uniform Vectors)
;;;;
;;;; Copyright 2001 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;; Copyright 2001-2006 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
......@@ -21,13 +21,23 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 15-Apr-2001 11:36 (eg)
;;;; Last file update: 16-Apr-2001 16:40 (eg)
;;;; Last file update: 27-Sep-2006 13:57 (eg)
;;;;
;; This implementation is done on the uniform layer present in the file
;; This implementation is built on the uniform layer present in the file
;; src/vector.c. Nearly everything is written in Scheme
;; define the C primitives to avoid warnings
(define %list->uvector #f)
(define %uvector->list #f)
(define %uvector-set! #f)
(define %uvector-ref #f)
(define %uvector-length #f)
(define %uvector #f)
(define %uvector? #f)
(define %make-uvector #f)
;; Internal coding (don't change it without modifying file vector.c
;; UVECT_S8 0
;; UVECT_U8 1
......
This source diff could not be displayed because it is too large. You can view the blob instead.
This source diff could not be displayed because it is too large. You can view the blob instead.
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 8-Jan-2000 14:48 (eg)
* Last file update: 6-Aug-2006 22:05 (eg)
* Last file update: 27-Sep-2006 10:31 (eg)
*
* This implementation is built by reverse engineering on an old SUNOS 4.1.1
* stdio.h. It has been simplified to fit the needs for STklos. In particular
......@@ -746,11 +746,9 @@ static int find_file_nature(SCM f)
return FILE_IS_OBJECT;
tmp = STk_read(f, TRUE);
if (tmp == STk_intern("STklos")) {
/* This is a bytecode file. Skip the (unused) version number*/
tmp = STk_read(f, TRUE);
if (tmp == STk_intern("STklos"))
return FILE_IS_BCODE;
}
/* We'll suppose that this is a source file, but we have read the first sexpr */
STk_rewind(f);
}
......@@ -845,6 +843,31 @@ DEFINE_PRIMITIVE("try-load", scheme_try_load, subr1, (SCM filename))
DEFINE_PRIMITIVE("%file-informations", file_informations, subr1, (SCM filename))
{
SCM f, res = STk_nil;
char *fname;
if (!STRINGP(filename)) STk_error_bad_file_name(filename);
fname = STRING_CHARS(filename);
/* Verify that file is not a directory */
if (!STk_dirp(fname)) {
f = STk_open_file(fname, "r");
if (f != STk_false) {
switch (find_file_nature(f)) {
case FILE_IS_SOURCE: break;
case FILE_IS_BCODE: res = STk_read(f, TRUE); break;
case FILE_IS_OBJECT: break;
}
STk_close_port(f);
}
}
return res;
}
int STk_init_fport(void)
{
vm_thread_t *vm = STk_get_current_vm();
......@@ -872,6 +895,7 @@ int STk_init_fport(void)
ADD_PRIMITIVE(port_idle);
// ADD_PRIMITIVE(dbg);
ADD_PRIMITIVE(file_informations);
return TRUE;
}
......
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 1-Mar-2000 19:51 (eg)
* Last file update: 26-Sep-2006 16:18 (eg)
* Last file update: 27-Sep-2006 13:41 (eg)
*/
// INLINER values
......@@ -841,12 +841,12 @@ CASE(GLOBAL_REF_PUSH) {
/* patch the code for optimize next accesses */
vm->pc[-2] = UGLOBAL_REF_PUSH;
vm->pc[-1] = add_global(&CDR(ref));
NEXT;
NEXT1;
}
CASE(UGLOBAL_REF_PUSH) {
/* Never produced by compiler */
push(fetch_global());
NEXT;
NEXT1;
}
......@@ -921,11 +921,11 @@ CASE(DEEP_LOCAL_REF) {
NEXT1;
}
CASE(LOCAL_REF0_PUSH) {push(FRAME_LOCAL(vm->env, 0)); NEXT;}
CASE(LOCAL_REF1_PUSH) {push(FRAME_LOCAL(vm->env, 1)); NEXT;}
CASE(LOCAL_REF2_PUSH) {push(FRAME_LOCAL(vm->env, 2)); NEXT;}
CASE(LOCAL_REF3_PUSH) {push(FRAME_LOCAL(vm->env, 3)); NEXT;}
CASE(LOCAL_REF4_PUSH) {push(FRAME_LOCAL(vm->env, 4)); NEXT;}
CASE(LOCAL_REF0_PUSH) {push(FRAME_LOCAL(vm->env, 0)); NEXT1;}
CASE(LOCAL_REF1_PUSH) {push(FRAME_LOCAL(vm->env, 1)); NEXT1;}
CASE(LOCAL_REF2_PUSH) {push(FRAME_LOCAL(vm->env, 2)); NEXT1;}
CASE(LOCAL_REF3_PUSH) {push(FRAME_LOCAL(vm->env, 3)); NEXT1;}
CASE(LOCAL_REF4_PUSH) {push(FRAME_LOCAL(vm->env, 4)); NEXT1;}
CASE(GLOBAL_SET) {
SCM ref;
......@@ -1776,7 +1776,9 @@ SCM STk_load_bcode_file(SCM f)
/* Save machine state */
save_pc = vm->pc; save_constants = vm->constants; save_env = vm->env;
/* Signature has been skipped during file type analysing */
/* Signature has been skipped during file type analysis (but not informations) */
STk_read(f, TRUE); /* skip infos */
for ( ; ; ) {
consts = STk_read_constant(f, TRUE); /* Read the constants */
if (consts == STk_eof) break;
......@@ -1812,7 +1814,6 @@ int STk_load_boot(char *filename)
/* Verify that the file is a bytecode file */
tmp = STk_read(f, TRUE);
if (tmp != STk_intern("STklos")) return -2;
STk_read(f, FALSE); /* Read the version -- unused for now */
tmp = STk_load_bcode_file(f);
if (tmp == STk_false) return -3;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment