Commit 8589777a authored by Erick Gallesio's avatar Erick Gallesio

current-module is now thread specific

parent 1839ff0b
2006-04-05 Erick Gallesio <eg@essi.fr>
* lib/computils.stk (symbol-bound?): Use SYMBOL-VALUE* instead of
SYMBOL-VALUE. This avoids some undefined symbols warnings.
2006-03-22 Erick Gallesio <eg@essi.fr>
* lib/srfi-27.stk (%random-source-current-time): Change
......
;;;;
;;;; utils.stk -- Compiler Utilities
;;;;
;;;; Copyright 2000-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;; Copyright 2000-2006 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 14-Mar-2001 13:57 (eg)
;;;; Last file update: 20-Nov-2004 19:34 (eg)
;;;; Last file update: 5-Apr-2006 10:14 (eg)
;;;;
......@@ -92,7 +92,7 @@
(define symbol-bound?
(let ((unbound (list 'unbound)))
(lambda (symbol)
(not (eq? (symbol-value symbol (current-module) unbound) unbound)))))
(not (eq? (symbol-value* symbol (current-module) unbound) unbound)))))
......
......@@ -2,7 +2,7 @@
*
* b o o l e a n . c -- Booleans and Equivalence predicates
*
* Copyright © 1993-2004 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
* Copyright © 1993-2006 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
*
*
* This program is free software; you can redistribute it and/or modify
......@@ -22,7 +22,7 @@
*
* Author: Erick Gallesio [eg@kaolin.unice.fr]
* Creation date: 23-Oct-1993 21:37
* Last file update: 12-May-2004 18:01 (eg)
* Last file update: 4-Apr-2006 18:44 (eg)
*/
#include "stklos.h"
......@@ -194,7 +194,8 @@ DEFINE_PRIMITIVE("eqv?", eqv, subr2, (SCM x, SCM y))
if (STk_oo_initialized) {
SCM fg, res;
fg = STk_lookup(STk_intern("object-eqv?"), STk_current_module, &res, FALSE);
fg = STk_lookup(STk_intern("object-eqv?"), STk_current_module(),
&res, FALSE);
res = STk_C_apply(fg, 2, x, y);
return res;
}
......@@ -323,7 +324,8 @@ DEFINE_PRIMITIVE("equal?", equal, subr2, (SCM x, SCM y))
if (STk_oo_initialized) {
SCM fg, res;
fg = STk_lookup(STk_intern("object-equal?"),STk_current_module,&res,FALSE);
fg = STk_lookup(STk_intern("object-equal?"),STk_current_module(),
&res,FALSE);
res = STk_C_apply(fg, 2, x, y);
return res;
}
......
/*
This file was automatically generated on Fri Mar 31 19:22:13 2006 by make-C-boot
This file was automatically generated on Wed Apr 5 10:14:25 2006 by make-C-boot
This is a dump of the image in file /mnt/users/eg/Projects/STklos/lib/boot.img3
***DO NOT EDIT BY HAND***
*/
#include "stklos.h"
char* STk_boot_consts = "#(pair? car map apply map* cdr for-each* *expander-list* assq expander? application-expander symbol? initial-expander install-expander! eq? delete! remove-expander! syntax-expand macro-expand \"too many optional parameters: ~a\" error gensym module-imports symbol-value* \"symbol ``~S'' not found\" symbol-value %%set-current-module find-module quote select-module %modules-stack current-module %create-module %module-create %module-restore raise %module-handler with-handler values void append define-module reverse %module-imports-set! memq import \"module `~S' does not exist\" %module-import module-exports %module-exports-set! export \"bad symbol `~S'\" %module-export in-module %symbol-define for-each %define-exported-symbols caar cdar cadr cddr caaar cdaar cadar cddar caadr cdadr caddr cdddr caaaar cdaaar cadaar cddaar caadar cdadar caddar cdddar caaadr cdaadr cadadr cddadr caaddr cdaddr cadddr cddddr %make-continuation %fresh-continuation? %restore-continuation %call/cc call/cc call-with-current-continuation dynamic-wind set-car! set-cdr! procedure? \"bad procedure ~S\" call-with-values open-file &i/o-filename-error location message \"cannot open file ~S\" format backtrace %vm-backtrace filename make-condition %set-std-port! close-port %make-with-file with-input-from-file current-input-port \"r\" with-output-to-file current-output-port \"w\" with-error-to-file current-error-port open-input-string with-input-from-string open-output-string get-output-string with-output-to-string %port-file-fd %make-with-port with-input-from-port with-output-to-port with-error-to-port %call-with open-input-file call-with-input-file open-output-file call-with-output-file rationalize \"bad rational ~S\" floor / positive? negative? - exact? 0.0 rational? %make-promise lambda delay length \"~a?\" string->symbol begin define make-struct-type \"make-~a\" make-struct and struct? struct-is-a? \"~a-~a\" %fast-struct-ref set! setter %fast-struct-set! define-struct %binary->n-ary %bit-or bit-or %bit-and bit-and %bit-xor bit-xor expt quotient bit-shift \"G\" symbol->string string? \"bad gensym prefix ~S\" number->string string-append string->uninterned-symbol filter remove filter! remove! equal? delete every any call-with-input-string call-with-output-string :read-char key-get :ready? :eof? :close vector %open-input-virtual open-input-virtual :write-char :write-string :flush %open-output-virtual open-output-virtual read read-from-string parse-expression *code-constants* list->vector %execute eval-from-string *%program-args* :argv argv :program-name program-name hash-table-hash %make-hash-table make-hash-table cons hash-table-map hash-table->alist hash-table-exists? hash-table-set! alist->hash-table hash-table-ref hash-table-update! hash-table-ref/default hash-table-update!/default hash-table-keys hash-table-values hash-table-for-each hash-table-fold hash-table-merge! hash-table-equivalence-function hash-table-hash-function hash-table-copy let list fluid-let generic? parameter? %procedure-plist :setter \"no setter defined for ~S\" key-set! %set-procedure-plist! vector-ref vector-set! string-ref string-set! slot-ref slot-set! struct-ref struct-set! let* clock \"Elapsed time: ~S ms\\n\" time (void) do + >= dotimes when while unless until \"call/ec\" call/ec ((normal . \"0\") (bold . \"1\") (no-bold . \"21\") (italic . \"2\") (no-italic . \"22\") (underline . \"4\") (no-undeline . \"24\") (blink . \"5\") (no-blink . \"25\") (reverse . \"7\") (no-reverse . \"27\") (black . \"30\") (bg-black . \"40\") (red . \"31\") (bg-red . \"41\") (green . \"32\") (bg-green . \"42\") (yellow . \"33\") (bg-yellow . \"43\") (blue . \"34\") (bg-blue . \"44\") (magenta . \"35\") (bg-magenta . \"45\") (cyan . \"36\") (bg-cyan . \"46\") (white . \"37\") (bg-white . \"47\")) assoc \"\" \"m\" \"\\x1b[\" \";\" ansi-color \"bad command ~S\" input-port? input-string-port? port->list \"bad port ~S\" eof-object? %port->list port->string read-line \"\\n\" port->sexp-list port->string-list display newline print printerr \"| \" exec exec-list argc module? apropos \"bad module ~S\" module-symbols string-find? \"**** ~A\\n**** EXIT\\n\" exit die running-os cygwin-windows posixify-file-name string-length #\\/ char=? \"/\" \".\" string-split decompose-file-name \"^(.*)/(.+)$\" \"\\\\1\" regexp-replace string=? dirname \"^(.*)/(.*)$\" \"\\\\2\" basename (unix cygwin-windows) memv windows #\\\\ #\\? file-separator \"~A~A~A\" make-path port-idle-register! %port-idle port-idle-unregister! port-idle-reset! expand-file-name %chmod write execute chmod \"bad option ~S\" integer? receive cond case-lambda \"bad clause ~S\" compute-arity = zero? else \"no matching clause in list ~S for ~S\" read-with-shared-structure write* write-with-shared-structure read/ss write/ss condition? condition-has-type? \"bad type for condition ~S\" condition-ref %define-condition-type-accessors x y parameterize require-extension \"requires at least one clause\" srfi not null? ok? if \"srfi-~a\" or %has-feature? \"extension ~S is absent\" *%autoloads* %try-load-tmp \":\" *path-separator* \"ostk\" \"stk\" \"scm\" \"so\" *load-suffixes* *load-verbose* *load-path* getenv %build-path-from-shell-variable \"STKLOS_LOAD_PATH\" %library-prefix version \"~/.stklos/ext\" \"/share/stklos/\" \"/lib/stklos/\" list? load-path \"bad list of path names ~S\" \"bad path name ~S\" make-parameter \"bad list of suffixes ~S\" load-suffixes load-verbose current-loading-file file-exists? file-is-readable? \".?.?/\" regexp-match %guess-pathname try-load \";; Loading file ~S.\\n\" \";; File ~S loaded.\\n\" load \"cannot load file ~S\" find-path require provide provided? require/provide member \"WARNING: ~S was not provided~%\" %%include include autoload-file remove-autoload! autoload \"~S has not been defined in ~S\" syntax-autoload (stklos STklos srfi-0 ((srfi-1 lists) \"srfi-1\") ((srfi-2 and-let*) \"srfi-2\") ((srfi-4 hvectors) \"srfi-4\") srfi-6 ((srfi-7 program) \"srfi-7\") srfi-8 ((srfi-9 records) \"srfi-9\") srfi-10 (srfi-11 \"srfi-11\") ((srfi-13 strings) \"srfi-13\") ((srfi-14 charsets) \"srfi-14\") ((srfi-16 case-lambda)) srfi-17 srfi-22 ((srfi-23 error)) (srfi-26 \"srfi-26\") ((srfi-27 random)) srfi-28 srfi-30 srfi-31 srfi-34 (srfi-35 \"srfi-35\") (srfi-36 \"srfi-36\") (conditions \"srfi-35\" \"srfi-36\") srfi-38 ((srfi-39 parameters)) srfi-48 srfi-55 (srfi-60 \"srfi-60\") srfi-62 (srfi-66 \"srfi-66\") ((srfi-69 hash-tables) \"srfi-69\") srfi-70) *all-features* srfi0-register-feature! (and or not) cond-expand \"no clause match\" \"srfi-0\" MBE some butlast \"negative argument ~S\" hyg:untag-no-tags hyg:untag-vanilla hyg:untag-lambda hyg:untag-letrec hyg:untag-named-let hyg:untag-let hyg:untag-let* hyg:untag-do hyg:untag-list hyg:untag-list* hyg:untag-quasiquote hyg:flatten mbe:ellipsis? mbe:split-at-ellipsis mbe:get-ellipsis-nestings mbe:ellipsis-sub-envs mbe:contained-in? hyg:rassq hyg:tag vector? vector->list ... hyg:untag quasiquote (if begin) (set! define) letrec case unquote \"takes exactly one expression\" unquote-splicing \"invalid context within quasiquote\" append! reverse! list-tail substring \"%%\" mbe:position mbe:append-map mbe:matches-pattern? mbe:get-bindings mbe:expand-pattern \"bad-arg\" \"no matching clause for ~S\" find-clause %find-macro-clause syntax-rules define-syntax \"in `~S', bad syntax-rules ~S\" define-macro args regexp-replace-all replace-string \"\\\\\\\\[0-9]\" regexp-match-positions string->number \"cannot match \\\\~A in model\" list-ref replace-submodels keyword? \"value expected after keyword ~S\" :input :output :error :wait :fork :args %run-process run-process SIGTERM process-signal process-kill SIGSTOP process-stop SIGCONT process-continue *compiler-port* warn-use-undef *compiler-options* (+ - * / = < <= > >= cons car cdr null? list not vector-ref vector-set! string-ref string-set! eq? eqv? equal? void) *compiler-inline* (%set-current-module %%set-current-module %%execute %%execute-handler) *always-inlined* *code-instr* *code-labels* label? NOP this-instr next-instr this-arg1 this-arg2 next-arg1 next-arg2 GOTO copy-tree RETURN PUSH (IM-FALSE IM-TRUE IM-NIL IM-MINUS1 IM-ZERO IM-ONE IM-VOID) IM-FALSE FALSE-PUSH IM-TRUE TRUE-PUSH IM-NIL NIL-PUSH IM-MINUS1 MINUS1-PUSH IM-ZERO ZERO-PUSH IM-ONE ONE-PUSH IM-VOID VOID-PUSH SMALL-INT INT-PUSH CONSTANT CONSTANT-PUSH IN-NOT (IN-NUMEQ IN-NUMDIFF IN-NUMLT IN-NUMGT IN-NUMLE IN-NUMGE IN-EQ IN-EQV IN-EQUAL) IN-NUMEQ IN-NUMDIFF IN-NUMLT IN-NUMGE IN-NUMGT IN-NUMLE IN-EQ IN-NOT-EQ IN-EQV IN-NOT-EQV IN-EQUAL IN-NOT-EQUAL JUMP-FALSE (IN-NUMEQ IN-NUMLT IN-NUMGT IN-NUMLE IN-NUMGE IN-EQ IN-EQV IN-EQUAL IN-NOT) JUMP-NUMDIFF JUMP-NUMEQ JUMP-NUMGE JUMP-NUMGT JUMP-NUMLE JUMP-NUMLT JUMP-NOT-EQ JUMP-NOT-EQV JUMP-NOT-EQUAL JUMP-TRUE GLOBAL-REF INVOKE GREF-INVOKE peephole ((NOP 0) (IM-FALSE 0) (IM-TRUE 0) (IM-NIL 0) (IM-MINUS1 0) (IM-ZERO 0) (IM-ONE 0) (IM-VOID 0) (SMALL-INT 1) (CONSTANT 1) (GLOBAL-REF 1) (UGLOBAL-REF 1) (LOCAL-REF0 0) (LOCAL-REF1 0) (LOCAL-REF2 0) (LOCAL-REF3 0) (LOCAL-REF4 0) (LOCAL-REF 1) (DEEP-LOCAL-REF 1) (GLOBAL-SET 1) (UGLOBAL-SET 1) (LOCAL-SET0 0) (LOCAL-SET1 0) (LOCAL-SET2 0) (LOCAL-SET3 0) (LOCAL-SET4 0) (LOCAL-SET 1) (DEEP-LOCAL-SET 1) (GOTO 1) (JUMP-FALSE 1) (JUMP-TRUE 1) (DEFINE-SYMBOL 1) (POP 0) (PUSH 0) (DBG-VM 1) (CREATE-CLOSURE 2) (RETURN 0) (PREPARE-CALL 0) (INVOKE 1) (TAIL-INVOKE 1) (ENTER-LET-STAR 1) (ENTER-LET 1) (ENTER-TAIL-LET-STAR 1) (ENTER-TAIL-LET 1) (LEAVE-LET 0) (PUSH-HANDLER 1) (POP-HANDLER 0) (END-OF-CODE 0) (IN-ADD2 0) (IN-SUB2 0) (IN-MUL2 0) (IN-DIV2 0) (IN-NUMEQ 0) (IN-NUMLT 0) (IN-NUMGT 0) (IN-NUMLE 0) (IN-NUMGE 0) (IN-INCR 0) (IN-DECR 0) (IN-CONS 0) (IN-NULLP 0) (IN-CAR 0) (IN-CDR 0) (IN-LIST 1) (IN-NOT 0) (IN-VREF 0) (IN-VSET 0) (IN-SREF 0) (IN-SSET 0) (IN-EQ 0) (IN-EQV 0) (IN-EQUAL 0) (IN-APPLY 2) (MAKE-EXPANDER 1) (SET-CUR-MOD 0) (UNUSED-1 0) (UNUSED-2 0) (FALSE-PUSH 0) (TRUE-PUSH 0) (NIL-PUSH 0) (MINUS1-PUSH 0) (ZERO-PUSH 0) (ONE-PUSH 0) (VOID-PUSH 0) (INT-PUSH 1) (CONSTANT-PUSH 1) (GREF-INVOKE 2) (UGREF-INVOKE 2) (IN-NUMDIFF 0) (IN-NOT-EQ 0) (IN-NOT-EQV 0) (IN-NOT-EQUAL 0) (JUMP-NUMDIFF 1) (JUMP-NUMEQ 1) (JUMP-NUMLT 1) (JUMP-NUMLE 1) (JUMP-NUMGT 1) (JUMP-NUMGE 1) (JUMP-NOT-EQ 1) (JUMP-NOT-EQV 1) (JUMP-NOT-EQUAL 1)) INSTRUCTION-SET *lab-equiv* \"non existent opcode ~S\" panic info-opcode (GOTO JUMP-FALSE JUMP-TRUE JUMP-NUMDIFF JUMP-NUMGE JUMP-NUMGT JUMP-NUMGE JUMP-NUMLT JUMP-NUMLE JUMP-NOT-EQ JUMP-NOT-EQV JUMP-NOT-EQUAL CREATE-CLOSURE PUSH-HANDLER) use-address? string-upcase #\\space make-string pretty-mnemonic old+ make-vector \"Instruction with more than 2 parameters ~S\" assemble \"L~A:\" \"\\t~A\\n\" display-code \"Cannot decode ~S opcode\" find-opcode remainder \"\\t;; ==> ~A\" vector-length \"\\n~A: ~A\" \" ~A\" \" ~S ~S\" \"cannot disassemble instruction (~S)\" \"\\n~A:\\n\" disassemble-code %procedure-code disassemble \"cannot disassemble ~S\" \"*** PANIC *** \" \"~A: \" %epair? \"~A:~A: \" %epair-file %epair-line \"~AError: ~A~A\\n\" compiler-error \"~Awarning: ~A~A\\n\" \"**** Warning;\\n~A~A\\n\" compiler-warning unbound symbol-bound? \"used outside of a quasiquote context\" compiler:time-display compiler:gen-line-number (set! *code-labels* 0) initialize-compilation get-generated-code new-label emit emit-label fetch-constant <= compile-constant \"bad usage in ~S\" compile-quote *known-globals* *forward-globals* known-var? new-global \"reference to undefined symbol ~S\" compiler-warn-undef warn-use-undef-postpone verify-global compiler-show-undefined-symbols \"ill formed definition ~S\" define->lambda \"bad definition\" compile DEFINE-SYMBOL \"bad variable name ~S\" \"internal define forbidden here\" compile-define symbol-in-env? GLOBAL-SET LOCAL-REF0 LOCAL-SET0 LOCAL-REF1 LOCAL-SET1 LOCAL-REF2 LOCAL-SET2 LOCAL-REF3 LOCAL-SET3 LOCAL-REF4 LOCAL-SET4 LOCAL-REF LOCAL-SET DEEP-LOCAL-REF DEEP-LOCAL-SET compile-access compile-reference \"~S is a bad symbol\" \"bad assignment syntax in ~S\" compile-set! \"bad syntax in ~S\" compile-if extended-lambda->lambda form e MAKE-EXPANDER macro-eval compile-define-macro compile-when compile-unless compile-and compile-or compile-begin extend-env extend-current-env rewrite-body CREATE-CLOSURE compile-user-lambda ext-lambda-key-get 'lambda make-keyword build-let* \"illegal ~a parameter: ~a\" \"optional\" \"keyword\" (:optional :key :rest) \"duplicate parameter ~S\" \"bad class name ~S\" \"bad procedure parameter ~S\" last-pair :rest :optional :key \"illegal lambda list ending with ~a\" \"rest parameter must be a single symbol\" parse-parameter-list rewrite-params-and-body method \"bad definition ~S\" compile-lambda compile-args compile-var-args PREPARE-CALL DBG-VM generate-PREPARE-CALL TAIL-INVOKE compile-normal-call can-be-inlined \"1 argument required (~A provided)\" \"2 arguments required (~A provided)\" \"3 arguments required (~A provided)\" SET-CUR-MOD \"1 arg. only (~S)\" %%execute-handler EXEC-HANDLER IN-INCR IN-ADD2 \"needs at least one argument\" IN-DECR IN-SUB2 * IN-MUL2 IN-DIV2 (= < > <= >=) O < > IN-CONS IN-CAR IN-CDR IN-NULLP IN-LIST IN-VREF IN-VSET IN-SREF IN-SSET eqv? \"unimplemented inline primitive ~S\" compile-primitive-call ENTER-TAIL-LET ENTER-LET LEAVE-LET \"bad number of parameters ~S\" compile-lambda-call compile-call \"duplicate binding ~S\" \"malformed binding ~S\" valid-let-bindings? \"ill formed letrec ~S\" compile-letrec \"ill formed named let ~S\" compile-named-let \"ill formed let ~S\" compile-let \"ill formed let* ~S\" ENTER-TAIL-LET-STAR ENTER-LET-STAR compile-let* \"invalid clause ~S\" \"else not in last clause ~S\" => rewrite-cond-clauses \"bad '=>' clause syntax ~S\" compile-cond ok \"duplicate case value ~S in ~S\" \"ill formed case clause ~S\" \"invalid clause syntax in ~S\" \"invalid case clause\" \"invalid case\" rewrite-case-clauses \"no key given\" compile-case \"bad binding ~S\" rewrite-do \"bad syntax\" compile-do backquotify 'quasiquote 'unquote assv compile-quasiquote PUSH-HANDLER POP-HANDLER compile-with-handler %read include-file \"bad include directive ~S\" compile-include compiler-maybe-do-autoload %%label \"bad usage ~S\" compile-%%label %%goto compile-%%goto compile-%%source-pos generate-line-info gen-line-info %%source-pos END-OF-CODE parse eval class-redefinition \"bad class ~S\" %error-bad-class \"bad generic function ~S\" %error-bad-generic \"bad method ~S\" %error-bad-method make-closure <top> specializers formals slot-definition-getter slot-definition-setter slot-definition-accessor declare-slots <generic> generic :name ??? %make <method> :generic-function :specializers :procedure basic-make \"cannot make ~S with ~S\" make class? name class-name direct-supers class-direct-supers direct-slots class-direct-slots direct-subclasses class-direct-subclasses direct-methods class-direct-methods cpl class-precedence-list slots class-slots slot-definition-name slot-definition-options :instance :allocation slot-definition-allocation :getter :accessor :init-form slot-definition-init-form :init-keyword slot-definition-init-keyword getters-n-setters slot-init-function class-slot-definition generic-function-name methods generic-function-methods method? generic-function method-generic-function method-specializers procedure method-procedure class-of is-a? <class> find-class compute-slots \"bad slot name ~S\" %compute-slots :dsupers :slots \"metaclass\" ensure-metaclass-with-supers ensure-metaclass ensure-class :metaclass define-class <object> \"super class ~S is duplicated in class ~S\" \"slot ~S is duplicated in class ~S\" ensure-generic-function define-generic :default add-method-in-classes! remove-method-in-classes! compute-new-list-of-methods add-method! next-method ensure-method ensure-method* \"gf\" define-method object-eqv? (<top> <top>) object-equal? write-object \"#[instance ~A]\" address-of (<object> <top>) slot-bound? \"#[~A ~A]\" (<class> <top>) \"#[~A ~A ~A]\" (<generic> <top>) \"#[~A ~A (~A)]\" display-object slot-unbound (<class> <object> <top>) \"slot ~S is unbound in #p~A (an object of class ~S)\" slot-missing (<class> <object> <top> . <top>) \"no slot with name `~S' in #p~A (an object of class ~S)\" no-next-method (<generic> <top> <top>) \"no next method for ~S in call ~S\" no-applicable-method \"no applicable method for ~S\\nin call ~S\" no-method \"no method defined for ~S\" shallow-clone (<object>) %allocate-instance deep-clone instance? remove-class-accessors (<class>) <accessor-method> update-direct-method (<method> <class> <class>) update-direct-subclass (<class> <class> <class>) (<class> <class>) redefined compute-get-n-set nfields :class :each-subclass :virtual :slot-ref :slot-set! \"a :slot-ref and a :slot-set! must be supplied in ~S\" :active :before-slot-ref :after-slot-ref :before-slot-set! :after-slot-set! %fast-slot-ref %fast-slot-set! \"allocation type \\\"~S\\\" is unknown\" compute-slot-accessors o val %slot-ref closure? %procedure-arity \"bad getter closure for slot `~S' in ~S: ~S\" \"bad setter closure for slot `~S' in ~S: ~S\" list* compute-getters-n-setters compute-cpl initialize %initialize-object (<method> <top>) allocate-instance make-instance (<class> . <top>) slot-exists-using-class? slot-bound-using-class? slot-ref-using-class slot-set-using-class! %modify-instance change-object-class change-class (<object> <class>) compute-applicable-methods find-method method-more-specific? (<method> <method> <top>) %method-more-specific? sort-applicable-methods sort apply-method (<generic> <top> <top> <top>) %set-next-method! apply-methods (<generic> <list> <top>) apply-generic class-subclasses class-methods list2set mapappend slot-value (<object> <top> <top>) describe \"describe\" %object-system-initialized struct-type %time time? second micro-second 1000000.0 time-seconds \"bad time ~S\" time->seconds number? real? round inexact->exact 1000000 seconds->time \"cannot convert ~S to a time\" \"bad number ~S\" :second :minute :hour :day :month :year %date date->seconds seconds->date make-date date? %seconds->date \"#[date ~A-~A-~A ~A:~A:~A]\" year month day hour minute struct-type-change-writer! date-second date-minute date-hour date-day date-month date-year date-week-day date-year-day date-dst date-tz struct->list seconds->list current-second current-date seconds->string \"bad string ~S\" #\\% #\\~ %seconds->string date->string \"date\" :undefined-symbol-warning pragma \"unknown pragma ~S\" stklos-pragma define-reader-ctor string-downcase string-lower string-upper \"*** Obsolete function set-load-path!. Use load-path instead.\\n\" set-load-path! \"*** Obsolete function set-load-suffixes!. Use load-suffixes instead.\\n\" set-load-suffixes! flush-output-port flush port-rewind rewind-file-port hash-table->list hash-table-put! hash-table-get hash-table-delete! hash-table-remove! REPL (main-repl repl) interactive-port? interactive? repl-level repl-backtrace :interactive \"TERM\" (\"rxvt\" \"xterm\" \"xterm-color\" \"linux\" \"cygwin\") do-color (help ?) blue bold \"Available Commands:\\n- ,backtrace ,bt Show the stack when last error occurred\\t\\n- ,quit ,q\\t Exit STklos\\n- ,help ,? ,h\\t This help\\n\" clear (quit q) (backtrace bt) %display-backtrace \"bad command name: ~S. Type ,help for some help\\n\" do-repl-command %build-error-location red \"**** Error:\\n~A: ~A\\n\" \"\\t(type \\\"\" underline \",help\" \"\\\" for more information)\\n\" display-error-message &error-message &message \"**** Unknown condition raised.\\n\" \"Condition type: ~A\\n\" struct-type-name \"Condition slots: ~S\\n\" \"**** The following non-condition was raised: ~S\\n\" repl-handler \"[~A] \" magenta \"~A> \" module-name black display-prompt :in G275 :out G276 :err G277 \";; ~A\\n\" repl %initialize-signals green \"STklos version ~A\\t\\t\\t[~A]\\n\" machine-type \"Copyright 1999-2006 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>\\n\" normal main-repl (REPL) compile-file \"compfile\" ((match-case . \"match\") (match-lambda . \"match\")) %print-usage \"getopt\" ((parse-arguments . \"getopt\")) ((trace . \"trace\") (untrace . \"trace\")) pp \"pp\" pretty-print random-integer \"srfi-27\" random-real ((with-exception-handler . \"srfi-34\") (guard . \"srfi-34\")) ((define-condition-type . \"srfi-35\") (condition . \"srfi-35\")) srfi48:help \"srfi-48\" srfi48:format-fixed %before-exit-hook main \"STKLOS_FRAMES\" \" - ...\\nSet shell variable STKLOS_FRAMES to set visible frames\\n\" \" - \" %procedure-name \"<<let/call>>\" \" @ [~S:~S]\\n\" \"???\" \"let\" \"**** Error while ~A ~S\\n\" \"\\tWhere: ~A\\n\" \"\\tReason: ~A\\n\" \"EXIT\\n\" %simple-fatal-exception-handler :no-init-file :load :file :sexpr \"~/.stklos/stklosrc\" \"loading file\" \"executing file\" \"evaluating\")";
char* STk_boot_consts = "#(pair? car map apply map* cdr for-each* *expander-list* assq expander? application-expander symbol? initial-expander install-expander! eq? delete! remove-expander! syntax-expand macro-expand \"too many optional parameters: ~a\" error gensym module-imports symbol-value* \"symbol ``~S'' not found\" symbol-value %%set-current-module find-module quote select-module %modules-stack current-module %create-module %module-create %module-restore raise %module-handler with-handler values void append define-module reverse %module-imports-set! memq import \"module `~S' does not exist\" %module-import module-exports %module-exports-set! export \"bad symbol `~S'\" %module-export in-module %symbol-define for-each %define-exported-symbols caar cdar cadr cddr caaar cdaar cadar cddar caadr cdadr caddr cdddr caaaar cdaaar cadaar cddaar caadar cdadar caddar cdddar caaadr cdaadr cadadr cddadr caaddr cdaddr cadddr cddddr %make-continuation %fresh-continuation? %restore-continuation %call/cc call/cc call-with-current-continuation dynamic-wind set-car! set-cdr! procedure? \"bad procedure ~S\" call-with-values open-file &i/o-filename-error location message \"cannot open file ~S\" format backtrace %vm-backtrace filename make-condition %set-std-port! close-port %make-with-file with-input-from-file current-input-port \"r\" with-output-to-file current-output-port \"w\" with-error-to-file current-error-port open-input-string with-input-from-string open-output-string get-output-string with-output-to-string %port-file-fd %make-with-port with-input-from-port with-output-to-port with-error-to-port %call-with open-input-file call-with-input-file open-output-file call-with-output-file rationalize \"bad rational ~S\" floor / positive? negative? - exact? 0.0 rational? %make-promise lambda delay length \"~a?\" string->symbol begin define make-struct-type \"make-~a\" make-struct and struct? struct-is-a? \"~a-~a\" %fast-struct-ref set! setter %fast-struct-set! define-struct %binary->n-ary %bit-or bit-or %bit-and bit-and %bit-xor bit-xor expt quotient bit-shift \"G\" symbol->string string? \"bad gensym prefix ~S\" number->string string-append string->uninterned-symbol filter remove filter! remove! equal? delete every any call-with-input-string call-with-output-string :read-char key-get :ready? :eof? :close vector %open-input-virtual open-input-virtual :write-char :write-string :flush %open-output-virtual open-output-virtual read read-from-string parse-expression *code-constants* list->vector %execute eval-from-string *%program-args* :argv argv :program-name program-name hash-table-hash %make-hash-table make-hash-table cons hash-table-map hash-table->alist hash-table-exists? hash-table-set! alist->hash-table hash-table-ref hash-table-update! hash-table-ref/default hash-table-update!/default hash-table-keys hash-table-values hash-table-for-each hash-table-fold hash-table-merge! hash-table-equivalence-function hash-table-hash-function hash-table-copy let list fluid-let generic? parameter? %procedure-plist :setter \"no setter defined for ~S\" key-set! %set-procedure-plist! vector-ref vector-set! string-ref string-set! slot-ref slot-set! struct-ref struct-set! let* clock \"Elapsed time: ~S ms\\n\" time (void) do + >= dotimes when while unless until \"call/ec\" call/ec ((normal . \"0\") (bold . \"1\") (no-bold . \"21\") (italic . \"2\") (no-italic . \"22\") (underline . \"4\") (no-undeline . \"24\") (blink . \"5\") (no-blink . \"25\") (reverse . \"7\") (no-reverse . \"27\") (black . \"30\") (bg-black . \"40\") (red . \"31\") (bg-red . \"41\") (green . \"32\") (bg-green . \"42\") (yellow . \"33\") (bg-yellow . \"43\") (blue . \"34\") (bg-blue . \"44\") (magenta . \"35\") (bg-magenta . \"45\") (cyan . \"36\") (bg-cyan . \"46\") (white . \"37\") (bg-white . \"47\")) assoc \"\" \"m\" \"\\x1b[\" \";\" ansi-color \"bad command ~S\" input-port? input-string-port? port->list \"bad port ~S\" eof-object? %port->list port->string read-line \"\\n\" port->sexp-list port->string-list display newline print printerr \"| \" exec exec-list argc module? apropos \"bad module ~S\" module-symbols string-find? \"**** ~A\\n**** EXIT\\n\" exit die running-os cygwin-windows posixify-file-name string-length #\\/ char=? \"/\" \".\" string-split decompose-file-name \"^(.*)/(.+)$\" \"\\\\1\" regexp-replace string=? dirname \"^(.*)/(.*)$\" \"\\\\2\" basename (unix cygwin-windows) memv windows #\\\\ #\\? file-separator \"~A~A~A\" make-path port-idle-register! %port-idle port-idle-unregister! port-idle-reset! expand-file-name %chmod write execute chmod \"bad option ~S\" integer? receive cond case-lambda \"bad clause ~S\" compute-arity = zero? else \"no matching clause in list ~S for ~S\" read-with-shared-structure write* write-with-shared-structure read/ss write/ss condition? condition-has-type? \"bad type for condition ~S\" condition-ref %define-condition-type-accessors x y parameterize require-extension \"requires at least one clause\" srfi not null? ok? if \"srfi-~a\" or %has-feature? \"extension ~S is absent\" *%autoloads* %try-load-tmp \":\" *path-separator* \"ostk\" \"stk\" \"scm\" \"so\" *load-suffixes* *load-verbose* *load-path* getenv %build-path-from-shell-variable \"STKLOS_LOAD_PATH\" %library-prefix version \"~/.stklos/ext\" \"/share/stklos/\" \"/lib/stklos/\" list? load-path \"bad list of path names ~S\" \"bad path name ~S\" make-parameter \"bad list of suffixes ~S\" load-suffixes load-verbose current-loading-file file-exists? file-is-readable? \".?.?/\" regexp-match %guess-pathname try-load \";; Loading file ~S.\\n\" \";; File ~S loaded.\\n\" load \"cannot load file ~S\" find-path require provide provided? require/provide member \"WARNING: ~S was not provided~%\" %%include include autoload-file remove-autoload! autoload \"~S has not been defined in ~S\" syntax-autoload (stklos STklos srfi-0 ((srfi-1 lists) \"srfi-1\") ((srfi-2 and-let*) \"srfi-2\") ((srfi-4 hvectors) \"srfi-4\") srfi-6 ((srfi-7 program) \"srfi-7\") srfi-8 ((srfi-9 records) \"srfi-9\") srfi-10 (srfi-11 \"srfi-11\") ((srfi-13 strings) \"srfi-13\") ((srfi-14 charsets) \"srfi-14\") ((srfi-16 case-lambda)) srfi-17 srfi-22 ((srfi-23 error)) (srfi-26 \"srfi-26\") ((srfi-27 random)) srfi-28 srfi-30 srfi-31 srfi-34 (srfi-35 \"srfi-35\") (srfi-36 \"srfi-36\") (conditions \"srfi-35\" \"srfi-36\") srfi-38 ((srfi-39 parameters)) srfi-48 srfi-55 (srfi-60 \"srfi-60\") srfi-62 (srfi-66 \"srfi-66\") ((srfi-69 hash-tables) \"srfi-69\") srfi-70) *all-features* srfi0-register-feature! (and or not) cond-expand \"no clause match\" \"srfi-0\" MBE some butlast \"negative argument ~S\" hyg:untag-no-tags hyg:untag-vanilla hyg:untag-lambda hyg:untag-letrec hyg:untag-named-let hyg:untag-let hyg:untag-let* hyg:untag-do hyg:untag-list hyg:untag-list* hyg:untag-quasiquote hyg:flatten mbe:ellipsis? mbe:split-at-ellipsis mbe:get-ellipsis-nestings mbe:ellipsis-sub-envs mbe:contained-in? hyg:rassq hyg:tag vector? vector->list ... hyg:untag quasiquote (if begin) (set! define) letrec case unquote \"takes exactly one expression\" unquote-splicing \"invalid context within quasiquote\" append! reverse! list-tail substring \"%%\" mbe:position mbe:append-map mbe:matches-pattern? mbe:get-bindings mbe:expand-pattern \"bad-arg\" \"no matching clause for ~S\" find-clause %find-macro-clause syntax-rules define-syntax \"in `~S', bad syntax-rules ~S\" define-macro args regexp-replace-all replace-string \"\\\\\\\\[0-9]\" regexp-match-positions string->number \"cannot match \\\\~A in model\" list-ref replace-submodels keyword? \"value expected after keyword ~S\" :input :output :error :wait :fork :args %run-process run-process SIGTERM process-signal process-kill SIGSTOP process-stop SIGCONT process-continue *compiler-port* warn-use-undef *compiler-options* (+ - * / = < <= > >= cons car cdr null? list not vector-ref vector-set! string-ref string-set! eq? eqv? equal? void) *compiler-inline* (%set-current-module %%set-current-module %%execute %%execute-handler) *always-inlined* *code-instr* *code-labels* label? NOP this-instr next-instr this-arg1 this-arg2 next-arg1 next-arg2 GOTO copy-tree RETURN PUSH (IM-FALSE IM-TRUE IM-NIL IM-MINUS1 IM-ZERO IM-ONE IM-VOID) IM-FALSE FALSE-PUSH IM-TRUE TRUE-PUSH IM-NIL NIL-PUSH IM-MINUS1 MINUS1-PUSH IM-ZERO ZERO-PUSH IM-ONE ONE-PUSH IM-VOID VOID-PUSH SMALL-INT INT-PUSH CONSTANT CONSTANT-PUSH IN-NOT (IN-NUMEQ IN-NUMDIFF IN-NUMLT IN-NUMGT IN-NUMLE IN-NUMGE IN-EQ IN-EQV IN-EQUAL) IN-NUMEQ IN-NUMDIFF IN-NUMLT IN-NUMGE IN-NUMGT IN-NUMLE IN-EQ IN-NOT-EQ IN-EQV IN-NOT-EQV IN-EQUAL IN-NOT-EQUAL JUMP-FALSE (IN-NUMEQ IN-NUMLT IN-NUMGT IN-NUMLE IN-NUMGE IN-EQ IN-EQV IN-EQUAL IN-NOT) JUMP-NUMDIFF JUMP-NUMEQ JUMP-NUMGE JUMP-NUMGT JUMP-NUMLE JUMP-NUMLT JUMP-NOT-EQ JUMP-NOT-EQV JUMP-NOT-EQUAL JUMP-TRUE GLOBAL-REF INVOKE GREF-INVOKE peephole ((NOP 0) (IM-FALSE 0) (IM-TRUE 0) (IM-NIL 0) (IM-MINUS1 0) (IM-ZERO 0) (IM-ONE 0) (IM-VOID 0) (SMALL-INT 1) (CONSTANT 1) (GLOBAL-REF 1) (UGLOBAL-REF 1) (LOCAL-REF0 0) (LOCAL-REF1 0) (LOCAL-REF2 0) (LOCAL-REF3 0) (LOCAL-REF4 0) (LOCAL-REF 1) (DEEP-LOCAL-REF 1) (GLOBAL-SET 1) (UGLOBAL-SET 1) (LOCAL-SET0 0) (LOCAL-SET1 0) (LOCAL-SET2 0) (LOCAL-SET3 0) (LOCAL-SET4 0) (LOCAL-SET 1) (DEEP-LOCAL-SET 1) (GOTO 1) (JUMP-FALSE 1) (JUMP-TRUE 1) (DEFINE-SYMBOL 1) (POP 0) (PUSH 0) (DBG-VM 1) (CREATE-CLOSURE 2) (RETURN 0) (PREPARE-CALL 0) (INVOKE 1) (TAIL-INVOKE 1) (ENTER-LET-STAR 1) (ENTER-LET 1) (ENTER-TAIL-LET-STAR 1) (ENTER-TAIL-LET 1) (LEAVE-LET 0) (PUSH-HANDLER 1) (POP-HANDLER 0) (END-OF-CODE 0) (IN-ADD2 0) (IN-SUB2 0) (IN-MUL2 0) (IN-DIV2 0) (IN-NUMEQ 0) (IN-NUMLT 0) (IN-NUMGT 0) (IN-NUMLE 0) (IN-NUMGE 0) (IN-INCR 0) (IN-DECR 0) (IN-CONS 0) (IN-NULLP 0) (IN-CAR 0) (IN-CDR 0) (IN-LIST 1) (IN-NOT 0) (IN-VREF 0) (IN-VSET 0) (IN-SREF 0) (IN-SSET 0) (IN-EQ 0) (IN-EQV 0) (IN-EQUAL 0) (IN-APPLY 2) (MAKE-EXPANDER 1) (SET-CUR-MOD 0) (UNUSED-1 0) (UNUSED-2 0) (FALSE-PUSH 0) (TRUE-PUSH 0) (NIL-PUSH 0) (MINUS1-PUSH 0) (ZERO-PUSH 0) (ONE-PUSH 0) (VOID-PUSH 0) (INT-PUSH 1) (CONSTANT-PUSH 1) (GREF-INVOKE 2) (UGREF-INVOKE 2) (IN-NUMDIFF 0) (IN-NOT-EQ 0) (IN-NOT-EQV 0) (IN-NOT-EQUAL 0) (JUMP-NUMDIFF 1) (JUMP-NUMEQ 1) (JUMP-NUMLT 1) (JUMP-NUMLE 1) (JUMP-NUMGT 1) (JUMP-NUMGE 1) (JUMP-NOT-EQ 1) (JUMP-NOT-EQV 1) (JUMP-NOT-EQUAL 1)) INSTRUCTION-SET *lab-equiv* \"non existent opcode ~S\" panic info-opcode (GOTO JUMP-FALSE JUMP-TRUE JUMP-NUMDIFF JUMP-NUMGE JUMP-NUMGT JUMP-NUMGE JUMP-NUMLT JUMP-NUMLE JUMP-NOT-EQ JUMP-NOT-EQV JUMP-NOT-EQUAL CREATE-CLOSURE PUSH-HANDLER) use-address? string-upcase #\\space make-string pretty-mnemonic old+ make-vector \"Instruction with more than 2 parameters ~S\" assemble \"L~A:\" \"\\t~A\\n\" display-code \"Cannot decode ~S opcode\" find-opcode remainder \"\\t;; ==> ~A\" vector-length \"\\n~A: ~A\" \" ~A\" \" ~S ~S\" \"cannot disassemble instruction (~S)\" \"\\n~A:\\n\" disassemble-code %procedure-code disassemble \"cannot disassemble ~S\" \"*** PANIC *** \" \"~A: \" %epair? \"~A:~A: \" %epair-file %epair-line \"~AError: ~A~A\\n\" compiler-error \"~Awarning: ~A~A\\n\" \"**** Warning;\\n~A~A\\n\" compiler-warning unbound symbol-bound? \"used outside of a quasiquote context\" compiler:time-display compiler:gen-line-number (set! *code-labels* 0) initialize-compilation get-generated-code new-label emit emit-label fetch-constant <= compile-constant \"bad usage in ~S\" compile-quote *known-globals* *forward-globals* known-var? new-global \"reference to undefined symbol ~S\" compiler-warn-undef warn-use-undef-postpone verify-global compiler-show-undefined-symbols \"ill formed definition ~S\" define->lambda \"bad definition\" compile DEFINE-SYMBOL \"bad variable name ~S\" \"internal define forbidden here\" compile-define symbol-in-env? GLOBAL-SET LOCAL-REF0 LOCAL-SET0 LOCAL-REF1 LOCAL-SET1 LOCAL-REF2 LOCAL-SET2 LOCAL-REF3 LOCAL-SET3 LOCAL-REF4 LOCAL-SET4 LOCAL-REF LOCAL-SET DEEP-LOCAL-REF DEEP-LOCAL-SET compile-access compile-reference \"~S is a bad symbol\" \"bad assignment syntax in ~S\" compile-set! \"bad syntax in ~S\" compile-if extended-lambda->lambda form e MAKE-EXPANDER macro-eval compile-define-macro compile-when compile-unless compile-and compile-or compile-begin extend-env extend-current-env rewrite-body CREATE-CLOSURE compile-user-lambda ext-lambda-key-get 'lambda make-keyword build-let* \"illegal ~a parameter: ~a\" \"optional\" \"keyword\" (:optional :key :rest) \"duplicate parameter ~S\" \"bad class name ~S\" \"bad procedure parameter ~S\" last-pair :rest :optional :key \"illegal lambda list ending with ~a\" \"rest parameter must be a single symbol\" parse-parameter-list rewrite-params-and-body method \"bad definition ~S\" compile-lambda compile-args compile-var-args PREPARE-CALL DBG-VM generate-PREPARE-CALL TAIL-INVOKE compile-normal-call can-be-inlined \"1 argument required (~A provided)\" \"2 arguments required (~A provided)\" \"3 arguments required (~A provided)\" SET-CUR-MOD \"1 arg. only (~S)\" %%execute-handler EXEC-HANDLER IN-INCR IN-ADD2 \"needs at least one argument\" IN-DECR IN-SUB2 * IN-MUL2 IN-DIV2 (= < > <= >=) O < > IN-CONS IN-CAR IN-CDR IN-NULLP IN-LIST IN-VREF IN-VSET IN-SREF IN-SSET eqv? \"unimplemented inline primitive ~S\" compile-primitive-call ENTER-TAIL-LET ENTER-LET LEAVE-LET \"bad number of parameters ~S\" compile-lambda-call compile-call \"duplicate binding ~S\" \"malformed binding ~S\" valid-let-bindings? \"ill formed letrec ~S\" compile-letrec \"ill formed named let ~S\" compile-named-let \"ill formed let ~S\" compile-let \"ill formed let* ~S\" ENTER-TAIL-LET-STAR ENTER-LET-STAR compile-let* \"invalid clause ~S\" \"else not in last clause ~S\" => rewrite-cond-clauses \"bad '=>' clause syntax ~S\" compile-cond ok \"duplicate case value ~S in ~S\" \"ill formed case clause ~S\" \"invalid clause syntax in ~S\" \"invalid case clause\" \"invalid case\" rewrite-case-clauses \"no key given\" compile-case \"bad binding ~S\" rewrite-do \"bad syntax\" compile-do backquotify 'quasiquote 'unquote assv compile-quasiquote PUSH-HANDLER POP-HANDLER compile-with-handler %read include-file \"bad include directive ~S\" compile-include compiler-maybe-do-autoload %%label \"bad usage ~S\" compile-%%label %%goto compile-%%goto compile-%%source-pos generate-line-info gen-line-info %%source-pos END-OF-CODE parse eval class-redefinition \"bad class ~S\" %error-bad-class \"bad generic function ~S\" %error-bad-generic \"bad method ~S\" %error-bad-method make-closure <top> specializers formals slot-definition-getter slot-definition-setter slot-definition-accessor declare-slots <generic> generic :name ??? %make <method> :generic-function :specializers :procedure basic-make \"cannot make ~S with ~S\" make class? name class-name direct-supers class-direct-supers direct-slots class-direct-slots direct-subclasses class-direct-subclasses direct-methods class-direct-methods cpl class-precedence-list slots class-slots slot-definition-name slot-definition-options :instance :allocation slot-definition-allocation :getter :accessor :init-form slot-definition-init-form :init-keyword slot-definition-init-keyword getters-n-setters slot-init-function class-slot-definition generic-function-name methods generic-function-methods method? generic-function method-generic-function method-specializers procedure method-procedure class-of is-a? <class> find-class compute-slots \"bad slot name ~S\" %compute-slots :dsupers :slots \"metaclass\" ensure-metaclass-with-supers ensure-metaclass ensure-class :metaclass define-class <object> \"super class ~S is duplicated in class ~S\" \"slot ~S is duplicated in class ~S\" ensure-generic-function define-generic :default add-method-in-classes! remove-method-in-classes! compute-new-list-of-methods add-method! next-method ensure-method ensure-method* \"gf\" define-method object-eqv? (<top> <top>) object-equal? write-object \"#[instance ~A]\" address-of (<object> <top>) slot-bound? \"#[~A ~A]\" (<class> <top>) \"#[~A ~A ~A]\" (<generic> <top>) \"#[~A ~A (~A)]\" display-object slot-unbound (<class> <object> <top>) \"slot ~S is unbound in #p~A (an object of class ~S)\" slot-missing (<class> <object> <top> . <top>) \"no slot with name `~S' in #p~A (an object of class ~S)\" no-next-method (<generic> <top> <top>) \"no next method for ~S in call ~S\" no-applicable-method \"no applicable method for ~S\\nin call ~S\" no-method \"no method defined for ~S\" shallow-clone (<object>) %allocate-instance deep-clone instance? remove-class-accessors (<class>) <accessor-method> update-direct-method (<method> <class> <class>) update-direct-subclass (<class> <class> <class>) (<class> <class>) redefined compute-get-n-set nfields :class :each-subclass :virtual :slot-ref :slot-set! \"a :slot-ref and a :slot-set! must be supplied in ~S\" :active :before-slot-ref :after-slot-ref :before-slot-set! :after-slot-set! %fast-slot-ref %fast-slot-set! \"allocation type \\\"~S\\\" is unknown\" compute-slot-accessors o val %slot-ref closure? %procedure-arity \"bad getter closure for slot `~S' in ~S: ~S\" \"bad setter closure for slot `~S' in ~S: ~S\" list* compute-getters-n-setters compute-cpl initialize %initialize-object (<method> <top>) allocate-instance make-instance (<class> . <top>) slot-exists-using-class? slot-bound-using-class? slot-ref-using-class slot-set-using-class! %modify-instance change-object-class change-class (<object> <class>) compute-applicable-methods find-method method-more-specific? (<method> <method> <top>) %method-more-specific? sort-applicable-methods sort apply-method (<generic> <top> <top> <top>) %set-next-method! apply-methods (<generic> <list> <top>) apply-generic class-subclasses class-methods list2set mapappend slot-value (<object> <top> <top>) describe \"describe\" %object-system-initialized struct-type %time time? second micro-second 1000000.0 time-seconds \"bad time ~S\" time->seconds number? real? round inexact->exact 1000000 seconds->time \"cannot convert ~S to a time\" \"bad number ~S\" :second :minute :hour :day :month :year %date date->seconds seconds->date make-date date? %seconds->date \"#[date ~A-~A-~A ~A:~A:~A]\" year month day hour minute struct-type-change-writer! date-second date-minute date-hour date-day date-month date-year date-week-day date-year-day date-dst date-tz struct->list seconds->list current-second current-date seconds->string \"bad string ~S\" #\\% #\\~ %seconds->string date->string \"date\" :undefined-symbol-warning pragma \"unknown pragma ~S\" stklos-pragma define-reader-ctor string-downcase string-lower string-upper \"*** Obsolete function set-load-path!. Use load-path instead.\\n\" set-load-path! \"*** Obsolete function set-load-suffixes!. Use load-suffixes instead.\\n\" set-load-suffixes! flush-output-port flush port-rewind rewind-file-port hash-table->list hash-table-put! hash-table-get hash-table-delete! hash-table-remove! REPL (main-repl repl) interactive-port? interactive? repl-level repl-backtrace :interactive \"TERM\" (\"rxvt\" \"xterm\" \"xterm-color\" \"linux\" \"cygwin\") do-color (help ?) blue bold \"Available Commands:\\n- ,backtrace ,bt Show the stack when last error occurred\\t\\n- ,quit ,q\\t Exit STklos\\n- ,help ,? ,h\\t This help\\n\" clear (quit q) (backtrace bt) %display-backtrace \"bad command name: ~S. Type ,help for some help\\n\" do-repl-command %build-error-location red \"**** Error:\\n~A: ~A\\n\" \"\\t(type \\\"\" underline \",help\" \"\\\" for more information)\\n\" display-error-message &error-message &message \"**** Unknown condition raised.\\n\" \"Condition type: ~A\\n\" struct-type-name \"Condition slots: ~S\\n\" \"**** The following non-condition was raised: ~S\\n\" repl-handler \"[~A] \" magenta \"~A> \" module-name black display-prompt :in G2999 :out G3000 :err G3001 \";; ~A\\n\" repl %initialize-signals green \"STklos version ~A\\t\\t\\t[~A]\\n\" machine-type \"Copyright 1999-2006 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>\\n\" normal main-repl (REPL) compile-file \"compfile\" ((match-case . \"match\") (match-lambda . \"match\")) %print-usage \"getopt\" ((parse-arguments . \"getopt\")) ((trace . \"trace\") (untrace . \"trace\")) pp \"pp\" pretty-print random-integer \"srfi-27\" random-real ((with-exception-handler . \"srfi-34\") (guard . \"srfi-34\")) ((define-condition-type . \"srfi-35\") (condition . \"srfi-35\")) srfi48:help \"srfi-48\" srfi48:format-fixed %before-exit-hook main \"STKLOS_FRAMES\" \" - ...\\nSet shell variable STKLOS_FRAMES to set visible frames\\n\" \" - \" %procedure-name \"<<let/call>>\" \" @ [~S:~S]\\n\" \"???\" \"let\" \"**** Error while ~A ~S\\n\" \"\\tWhere: ~A\\n\" \"\\tReason: ~A\\n\" \"EXIT\\n\" %simple-fatal-exception-handler :no-init-file :load :file :sexpr \"~/.stklos/stklosrc\" \"loading file\" \"executing file\" \"evaluating\")";
STk_instr STk_boot_code [] = {
0x23, /* 0 */
......@@ -1655,7 +1655,7 @@ STk_instr STk_boot_code [] = {
0x21, 0x56, 0x66, 0x3, 0x21, 0x12, 0x100, 0x21, 0xa, 0x3, /* 16430 */
0x27, 0x4, 0x24, 0x24, 0x1f, 0x272, 0x25, 0x55, 0x273, 0x3f, /* 16440 */
0x1, 0x21, 0x29, 0x1, 0x23, 0x14, 0x1, 0x25, 0xc, 0x21, /* 16450 */
0x25, 0x56, 0x1f, 0x0, 0x21, 0x12, 0x100, 0x21, 0x56, 0x19, /* 16460 */
0x25, 0x56, 0x1f, 0x0, 0x21, 0x12, 0x100, 0x21, 0x56, 0x17, /* 16460 */
0x3, 0x21, 0x12, 0x100, 0x59, 0x24, 0x2c, 0x1f, 0x274, 0x23, /* 16470 */
0xb, 0xffff, 0x25, 0x55, 0x1d1, 0x55, 0x275, 0xa, 0x14, 0x27, /* 16480 */
0x2, 0x24, 0x1f, 0x1d1, 0x23, 0xb, 0xffff, 0x25, 0x55, 0x1d3, /* 16490 */
......
No preview for this file type
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@essi.fr]
* Creation date: 22-May-2004 08:57 (eg)
* Last file update: 1-Feb-2006 18:13 (eg)
* Last file update: 4-Apr-2006 20:07 (eg)
*/
#include "stklos.h"
......@@ -465,7 +465,7 @@ SCM STk_make_C_cond(SCM type, int nargs, ...)
int STk_init_cond(void)
{
SCM module = STk_current_module;
SCM module = STk_STklos_module;
/* Build the special value SRFI-35 &condition */
NEWCELL(root_condition, struct_type);
......
......@@ -2,7 +2,7 @@
*
* e n v . c -- Environment management
*
* Copyright 1993-2005 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
* Copyright 1993-2006 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
*
*
* This program is free software; you can redistribute it and/or modify
......@@ -22,11 +22,13 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 23-Oct-1993 21:37
* Last file update: 23-Aug-2005 08:28 (eg)
* Last file update: 4-Apr-2006 23:58 (eg)
*/
#include "stklos.h"
#include "hash.h"
#include "vm.h"
#include "thread.h"
static void error_bad_module_name(SCM obj)
......@@ -82,8 +84,7 @@ struct module_obj {
#define VISIBLE_P(symb, mod) (STk_memq((symb), MODULE_EXPORTS(mod))!=STk_false)
SCM STk_current_module; /* The current module */
static SCM stklos_module; /* The module whose name is STklos */
SCM STk_STklos_module; /* The module whose name is STklos */
static SCM all_modules; /* List of all knowm modules */
......@@ -102,7 +103,7 @@ static SCM STk_makemodule(SCM name)
NEWCELL(z, module);
MODULE_NAME(z) = name;
MODULE_EXPORTS(z) = STk_nil;
MODULE_IMPORTS(z) = (name == STk_void)? STk_nil : LIST1(stklos_module);
MODULE_IMPORTS(z) = (name == STk_void)? STk_nil : LIST1(STk_STklos_module);
/* Initialize the associated hash table & stor the module in the global list*/
STk_hashtable_init(&MODULE_HASH_TABLE(z), HASH_VAR_FLAG);
all_modules = STk_cons(z, all_modules);
......@@ -115,7 +116,7 @@ static SCM find_module(SCM name, int create)
SCM tmp;
if (name == STk_intern("STklos") || name == STk_intern("stklos"))
return stklos_module;
return STk_STklos_module;
for (tmp = all_modules; !NULLP(tmp); tmp = CDR(tmp)) {
if (MODULE_NAME(CAR(tmp)) == name)
......@@ -141,9 +142,10 @@ DEFINE_PRIMITIVE("%create-module", create_module, subr1, (SCM name))
DEFINE_PRIMITIVE("%select-module", select_module, subr1, (SCM module))
{
vm_thread_t *vm = STk_get_current_vm();
if (!MODULEP(module)) error_bad_module(module);
STk_current_module = module;
vm->current_module= module;
return STk_void;
}
......@@ -224,9 +226,14 @@ DEFINE_PRIMITIVE("find-module", scheme_find_module, subr12, (SCM name, SCM def))
* @end lisp
doc>
*/
DEFINE_PRIMITIVE("current-module", scheme_current_module, subr0, (void))
DEFINE_PRIMITIVE("current-module", current_module, subr0, (void))
{
return STk_current_module;
if (STk_primordial_thread) {
vm_thread_t *vm = STk_get_current_vm();
return vm->current_module;
} else {
return STk_STklos_module;
}
}
......@@ -272,7 +279,7 @@ DEFINE_PRIMITIVE("module-exports", module_exports, subr1, (SCM module))
if (!MODULEP(module)) error_bad_module(module);
/* STklos module is special: everything is exported ==> module-symbols */
return (module == stklos_module) ?
return (module == STk_STklos_module) ?
STk_hash_keys(&MODULE_HASH_TABLE(module)) :
MODULE_EXPORTS(module);
}
......@@ -413,8 +420,8 @@ SCM STk_lookup(SCM symbol, SCM env, SCM *ref, int err_if_unbound)
/* Not found in the imported modules. Try in the stklos module (if we
* didn't had searched it yet
*/
if (env != stklos_module) {
res = STk_hash_get_variable(&MODULE_HASH_TABLE(stklos_module), symbol, &i);
if (env != STk_STklos_module) {
res = STk_hash_get_variable(&MODULE_HASH_TABLE(STk_STklos_module), symbol, &i);
if (res) {
*ref = res;
return CDR(res);
......@@ -456,8 +463,7 @@ int STk_init_env(void)
all_modules = STk_nil;
/* Create the stklos module */
stklos_module = STk_makemodule(STk_void); /* will be changed later */
STk_current_module = stklos_module;
STk_STklos_module = STk_makemodule(STk_void); /* will be changed later */
/* Declare the extended types module_obj and frame_obj */
DEFINE_XTYPE(module, &xtype_module);
......@@ -468,7 +474,7 @@ int STk_init_env(void)
int STk_late_init_env(void)
{
/* Now that symbols are initialized change the STklos module name */
MODULE_NAME(stklos_module) = STk_intern("stklos");
MODULE_NAME(STk_STklos_module) = STk_intern("stklos");
/* ==== Undocumented primitives ==== */
ADD_PRIMITIVE(create_module);
......@@ -479,7 +485,7 @@ int STk_late_init_env(void)
/* ==== User primitives ==== */
ADD_PRIMITIVE(modulep);
ADD_PRIMITIVE(scheme_find_module);
ADD_PRIMITIVE(scheme_current_module);
ADD_PRIMITIVE(current_module);
ADD_PRIMITIVE(module_name);
ADD_PRIMITIVE(module_imports);
ADD_PRIMITIVE(module_exports);
......@@ -492,4 +498,3 @@ int STk_late_init_env(void)
return TRUE;
}
/*
* f p o r t . c -- File ports
*
* Copyright 2000-2005 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
* Copyright 2000-2006 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
*
*
* This program is free software; you can redistribute it and/or modify
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 8-Jan-2000 14:48 (eg)
* Last file update: 13-Sep-2005 22:41 (eg)
* Last file update: 4-Apr-2006 18:59 (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
......@@ -752,7 +752,7 @@ SCM STk_load_source_file(SCM f)
*/
sexpr = STk_read_constant(f, STk_read_case_sensitive);
if (sexpr == STk_eof) break;
eval = STk_lookup(eval_symb, STk_current_module, &ref, TRUE);
eval = STk_lookup(eval_symb, STk_current_module(), &ref, TRUE);
STk_C_apply(eval, 1, sexpr);
}
STk_close_port(f);
......
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 5-Jan-2000 12:17 (eg)
* Last file update: 2-Feb-2006 22:25 (eg)
* Last file update: 4-Apr-2006 23:52 (eg)
*/
......
/*
* m i s c . c -- Misc. functions
*
* Copyright © 2000-2005 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
* Copyright © 2000-2006 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
*
*
* This program is free software; you can redistribute it and/or modify
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 9-Jan-2000 12:50 (eg)
* Last file update: 25-Apr-2005 17:14 (eg)
* Last file update: 4-Apr-2006 19:00 (eg)
*/
#include "stklos.h"
......@@ -55,7 +55,7 @@ void STk_add_primitive(struct primitive_obj *o)
SCM symbol;
symbol = STk_intern(o->name);
STk_define_variable(symbol, (SCM) o, STk_current_module);
STk_define_variable(symbol, (SCM) o, STk_current_module());
}
......@@ -484,8 +484,8 @@ DEFINE_PRIMITIVE("%debug", set_debug, subr0, (void))
DEFINE_PRIMITIVE("%test", test, subr1, (SCM s))
{
/* A special place for doing tests */
STk_eval_C_string("(display \"Hello, world!\")", STk_current_module);
STk_eval_C_string("(display (fact 200))", STk_current_module);
STk_eval_C_string("(display \"Hello, world!\")", STk_current_module());
STk_eval_C_string("(display (fact 200))", STk_current_module());
return STk_void;
}
#endif
......
......@@ -2,7 +2,7 @@
*
* o b j e c t . c -- Objects support
*
* Copyright 1994-2005 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
* Copyright 1994-2006 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 9-Feb-1994 15:56
* Last file update: 25-Apr-2005 17:06 (eg)
* Last file update: 4-Apr-2006 20:10 (eg)
*/
#include "stklos.h"
......@@ -29,7 +29,7 @@
#include "struct.h"
#define GF_VAL(name) (STk_lookup(STk_intern(name), \
STk_current_module, &unused, FALSE))
STk_current_module(), &unused, FALSE))
#define CALL_GF1(name,a) (STk_C_apply(GF_VAL(name), 1, (a)))
#define CALL_GF2(name,a,b) (STk_C_apply(GF_VAL(name), 2, (a), (b)))
#define CALL_GF3(name,a,b,c) (STk_C_apply(GF_VAL(name), 3, (a), (b), (c)))
......@@ -812,6 +812,7 @@ static void create_Top_Object_Class(void)
STk_cons(STk_intern("getters-n-setters"),
STk_cons(STk_intern("redefined"),
STk_nil))))))))));
SCM current_module = STk_STklos_module;
/* ========== Creation of the <Class> class ========== */
......@@ -833,21 +834,21 @@ static void create_Top_Object_Class(void)
INST_SLOT(Class, S_getters_n_setters) = INST_ACCESSORS(Class);
INST_SLOT(Class, S_redefined) = STk_false;
STk_define_variable(tmp, Class, STk_current_module);
STk_define_variable(tmp, Class, current_module);
/* ========== Creation of the <Top> class ========== */
tmp = STk_intern("<top>");
Top = basic_make_class(Class, tmp, STk_nil, STk_nil);
STk_define_variable(tmp, Top, STk_current_module);
STk_define_variable(tmp, Top, current_module);
/* ========== Creation of the <Object> class ========== */
tmp = STk_intern("<object>");
Object = basic_make_class(Class, tmp, LIST1(Top), STk_nil);
STk_define_variable(tmp, Object, STk_current_module);
STk_define_variable(tmp, Object, current_module);
/*
* <top> <object> and <class> were partially initialized.
......@@ -864,7 +865,7 @@ static void mk_cls(SCM *var, char *name, SCM meta, SCM super, SCM slots)
SCM tmp = STk_intern(name);
*var = basic_make_class(meta, tmp, LIST1(super), slots);
STk_define_variable(tmp, *var, STk_current_module);
STk_define_variable(tmp, *var, STk_STklos_module);
}
static void make_standard_classes(void)
......@@ -1088,7 +1089,7 @@ static void print_instance(SCM inst, SCM port, int mode)
SCM fct, res;
fct_name = (mode == DSP_MODE) ? "display-object" : "write-object";
fct = STk_lookup(STk_intern(fct_name), STk_current_module, &res, FALSE);
fct = STk_lookup(STk_intern(fct_name), STk_current_module(), &res, FALSE);
if (fct == STk_void) {
/* Do a default print */
......
/*
* parameter.c -- Parameter Objects (SRFI-39)
*
* Copyright © 2003-2005 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
* Copyright © 2003-2006 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
*
*
* This program is free software; you can redistribute it and/or modify
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@essi.fr]
* Creation date: 1-Jul-2003 11:38 (eg)
* Last file update: 26-Dec-2005 19:05 (eg)
* Last file update: 4-Apr-2006 19:02 (eg)
*/
......@@ -92,7 +92,7 @@ SCM STk_make_C_parameter(SCM symbol, SCM value, SCM (*proc)(SCM new_value))
PARAMETER_C_TYPE(z) = 1;
/* Bind it to the given symbol */
STk_define_variable(STk_intern(symbol), z, STk_current_module);
STk_define_variable(STk_intern(symbol), z, STk_current_module());
return z;
}
......
......@@ -20,7 +20,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 17-Feb-1993 12:27
* Last file update: 7-Feb-2006 18:24 (eg)
* Last file update: 4-Apr-2006 19:07 (eg)
*
*/
......@@ -674,7 +674,7 @@ static SCM internal_format(int argc, SCM *argv, int error)
if (argc-- <= 0) goto TooMuch;
pp = STk_lookup(STk_intern("pp"),
STk_current_module,
STk_current_module(),
&ref,
TRUE);
STk_print(STk_C_apply(pp, 3, *argv--,
......@@ -714,7 +714,7 @@ static SCM internal_format(int argc, SCM *argv, int error)
* Call the Scheme routine srfi48:format-fixed
*/
ff = STk_lookup(STk_intern("srfi48:format-fixed"),
STk_current_module,
STk_current_module(),
&ref,
TRUE);
tmp = STk_C_apply(ff, 3,
......@@ -747,7 +747,7 @@ static SCM internal_format(int argc, SCM *argv, int error)
/* Do (apply format port fmt args) */
STk_C_apply_list(STk_lookup(STk_intern("format"),
STk_current_module, &ref, TRUE),
STk_current_module(), &ref, TRUE),
STk_cons(port, STk_cons(fmt, args)));
break;
}
......@@ -756,7 +756,7 @@ static SCM internal_format(int argc, SCM *argv, int error)
SCM ref, help;
help = STk_lookup(STk_intern("srfi48:help"),
STk_current_module,
STk_current_module(),
&ref,
TRUE);
STk_C_apply(help, 1, port);
......@@ -1284,7 +1284,7 @@ DEFINE_PRIMITIVE("port-rewind", port_rewind, subr1, (SCM port))
\*===========================================================================*/
static void initialize_io_conditions(void)
{
SCM module = STk_current_module;
SCM module = STk_STklos_module;
#define DEFCOND(x, name, parent, slots) \
x = STk_defcond_type(name, parent, slots, module)
......
......@@ -20,7 +20,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: ??-Oct-1993 ??:??
* Last file update: 7-Feb-2006 17:53 (eg)
* Last file update: 4-Apr-2006 19:31 (eg)
*
*/
......@@ -42,7 +42,7 @@ int STk_read_case_sensitive = 0;
#define PLACEHOLDERP(x) (CONSP(x) && (BOXED_INFO(x) & CONS_PLACEHOLDER))
#define PLACEHOLDER_VAL(x) (CDR(x))
#define SYMBOL_VALUE(x,ref) STk_lookup((x), STk_current_module, &(ref), FALSE)
#define SYMBOL_VALUE(x,ref) STk_lookup((x), STk_current_module(), &(ref), FALSE)
/*===========================================================================*\
*
......@@ -732,7 +732,7 @@ DEFINE_PRIMITIVE("define-reader-ctor",reader_ctor, subr2, (SCM symbol, SCM proc)
static SCM read_srfi10(SCM port, SCM l)
{
int len = STk_int_length(l);
SCM tmp, ref;
SCM tmp;
if (len < 0)
signal_error(port, "bad list in a #,(...) form ~S", l);
......@@ -804,7 +804,7 @@ int STk_init_reader(void)
STk_intern("column"),
STk_intern("position"),
STk_intern("span")),
STk_current_module);
STk_STklos_module);
/* Declare SRFI-10 support function */
......
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 28-Dec-1999 21:19 (eg)
* Last file update: 1-Feb-2006 13:41 (eg)
* Last file update: 4-Apr-2006 19:26 (eg)
*/
#include <stklos.h>
......@@ -134,7 +134,8 @@ static void build_scheme_args(int argc, char *argv[], char *argv0)
ADD_BOOL_OPTION(vanilla, ":no-init-file");
ADD_BOOL_OPTION(STk_interactive, ":interactive")
STk_define_variable(STk_intern("*%program-args*"), options, STk_current_module);
STk_define_variable(STk_intern("*%program-args*"), options,
STk_STklos_module);
}
int main(int argc, char *argv[])
......
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 28-Dec-1999 22:58 (eg)
* Last file update: 7-Feb-2006 16:07 (eg)
* Last file update: 4-Apr-2006 19:23 (eg)
*/
#ifndef STKLOS_H
......@@ -378,8 +378,6 @@ struct frame_obj {
/* modules are defined in env.c but are private */
#define MODULEP(p) (BOXED_TYPE_EQ((p), tc_module))
extern SCM STk_current_module;
SCM STk_make_frame(int len);
SCM STk_clone_frame(SCM f);
......@@ -390,7 +388,11 @@ void STk_define_variable(SCM symbol, SCM value, SCM module);
int STk_init_env(void);
int STk_late_init_env(void); /* must be done after symbol initialization */
extern SCM STk_STklos_module;
EXTERN_PRIMITIVE("%create-module", create_module, subr1, (SCM name))
EXTERN_PRIMITIVE("current-module", current_module, subr0, (void))
EXTERN_PRIMITIVE("%select-module", select_module, subr1, (SCM module))
/*
------------------------------------------------------------------------------
......
......@@ -16,7 +16,7 @@
*
* Author: Erick Gallesio [eg@kaolin.unice.fr]
* Creation date: 29-Mar-1994 10:57
* Last file update: 3-Feb-2006 17:12 (eg)
* Last file update: 4-Apr-2006 19:26 (eg)
*/
#include <unistd.h>
......@@ -1027,6 +1027,8 @@ DEFINE_PRIMITIVE("%chmod", change_mode, subr2, (SCM file, SCM value))
int STk_init_system(void)
{
SCM current_module = STk_STklos_module;
/* Create the system-date structure-type */
date_type = STk_make_struct_type(STk_intern("%date"),
STk_false,
......@@ -1040,14 +1042,14 @@ int STk_init_system(void)
STk_intern("year-day"),
STk_intern("dst"),
STk_intern("tz")));
STk_define_variable(STk_intern("%date"), date_type, STk_current_module);
STk_define_variable(STk_intern("%date"), date_type, current_module);
/* Create the time structure-type */
time_type = STk_make_struct_type(STk_intern("%time"),
STk_false,
LIST2(STk_intern("second"),
STk_intern("microsecond")));
STk_define_variable(STk_intern("%time"), time_type, STk_current_module);
STk_define_variable(STk_intern("%time"), time_type, current_module);
/* Declare primitives */
ADD_PRIMITIVE(clock);
......
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@essi.fr]
* Creation date: 23-Jan-2006 12:14 (eg)
* Last file update: 5-Feb-2006 21:52 (eg)
* Last file update: 4-Apr-2006 23:58 (eg)
*/
......@@ -33,7 +33,7 @@
#include "vm.h"
#include "thread.h"
static SCM primordial;
SCM STk_primordial_thread = NULL;
static SCM cond_thread_terminated, cond_join_timeout, cond_thread_abandonned_mutex;
static SCM all_threads = STk_nil;
......@@ -345,6 +345,7 @@ static struct extended_type_descr xtype_thread = {
int STk_init_threads(int stack_size)
{
vm_thread_t *vm = STk_allocate_vm(stack_size);
SCM primordial;
/* Thread Type declaration */
DEFINE_XTYPE(thread, &xtype_thread);
......@@ -356,19 +357,20 @@ int STk_init_threads(int stack_size)
/* Define the threads exceptions */
cond_thread_terminated = STk_defcond_type("&thread-terminated", STk_false,
LIST1(STk_intern("canceller")),
STk_current_module);
STk_STklos_module);
cond_thread_abandonned_mutex = STk_defcond_type("&thread-abandonned-mutex",
STk_false,
STk_nil,
STk_current_module);
STk_STklos_module);
cond_join_timeout = STk_defcond_type("&thead-join-timeout", STk_false,
STk_nil, STk_current_module);
STk_nil, STk_STklos_module);
/* Wrap the main thread in a thread called "primordial" */
primordial = do_make_thread(STk_false, STk_Cstring2string("primordial"));
THREAD_STATE(primordial) = th_runnable;
THREAD_VM(primordial) = vm;
vm->scheme_thread = primordial;
STk_primordial_thread = primordial;
/* Thread primitives */
ADD_PRIMITIVE(current_thread);
......
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@essi.fr]
* Creation date: 4-Feb-2006 11:03 (eg)
* Last file update: 4-Feb-2006 11:04 (eg)
* Last file update: 4-Apr-2006 23:55 (eg)
*/
//FIX:
......@@ -53,8 +53,11 @@ struct thread_obj {
#define THREAD_SPECIFIC(p) (((struct thread_obj *) (p))->specific)
#define THREAD_RESULT(p) (((struct thread_obj *) (p))->end_result)
#define THREAD_EXCEPTION(p) (((struct thread_obj *) (p))->end_exception)
#define THREAD_CURMOD(p) (((struct thread_obj *) (p))->current_module)
#define THREAD_STATE(p) (((struct thread_obj *) (p))->state)
#define THREAD_VM(p) (((struct thread_obj *) (p))->vm)
#define THREAD_PTHREAD(p) (((struct thread_obj *) (p))->pthread)
#define THREAD_MYMUTEX(p) (((struct thread_obj *) (p))->mymutex)
#define THREAD_MYCONDV(p) (((struct thread_obj *) (p))->mycondv)
extern SCM STk_primordial_thread;
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 1-Mar-2000 19:51 (eg)
* Last file update: 7-Feb-2006 18:27 (eg)
* Last file update: 4-Apr-2006 19:32 (eg)
*/
// INLINER values
......@@ -131,13 +131,14 @@ vm_thread_t *STk_allocate_vm(int stack_size)
}
/* Initialize the VM registers */
vm->sp = vm->stack + vm->stack_len;
vm->fp = vm->sp;
vm->val = STk_void;
vm->env = STk_current_module;
vm->handlers = NULL;
vm->top_jmp_buf = NULL;
vm->scheme_thread = STk_false;
vm->sp = vm->stack + vm->stack_len;
vm->fp = vm->sp;
vm->val = STk_void;
vm->current_module = STk_current_module();
vm->env = vm->current_module;
vm->handlers = NULL;
vm->top_jmp_buf = NULL;
vm->scheme_thread = STk_false;
return vm;
}
......@@ -502,7 +503,7 @@ DEFINE_PRIMITIVE("%execute", execute, subr23, (SCM code, SCM consts, SCM envt))
STk_instr *vinstr, *p;
vm_thread_t *vm = STk_get_current_vm();
if (!envt) envt = STk_current_module;
if (!envt) envt = vm->current_module;