Commit 18c69caf authored by Erick's avatar Erick

Corrected some problems on character encoding depending of the SHELL LC_* varisables

parent e70e2df6
......@@ -6,7 +6,7 @@ This is a dump of the image in file /home/eg/Projects/STklos/lib/boot.img3
#include "stklos.h"
char* STk_boot_consts = "#(pair? car map apply map* cdr for-each* filter filter-map append append-map append! append-map! \"\" string->symbol \"~a\" format string-append symbol-append make-parameter stklos-debug-level :name \"STklos\" *%system-state-plist* compiler-known-globals memq register-new-global! *expander-list* *expander-list-src* *expander-published* assq expander? application-expander symbol? initial-expander set-cdr! install-expander! push-expander! caar delete-expander! expander-published-reset! symbol-value* compiler-warning STKLOS-COMPILER find-module reverse! assoc export-syntax \"cannot find source of syntax named ~S\" expander-published-sources expander-published-add! syntax-expand macro-expand macro-expand* %macro-expand* \"too many optional parameters: ~a\" error gensym module-imports \"symbol ``~S'' not found\" symbol-value %%set-current-module quote select-module %modules-stack current-module %create-module %module-create %module-restore raise %module-handler with-handler values void define-module reverse %module-imports-set! import \"module `~S' does not exist\" %module-import \"cannot find module ~S\" module-exports %symbol-alias \"symbol ~S is not exported from module ~S\" for-each %module-export %module-aliases cdar every \"bad import clause ~S\" begin call-with-values %module-exports-set! export \"bad symbol `~S'\" %%publish-syntax in-module 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 dynamic-wind %thread-dynwind-stack set-car! %thread-dynwind-stack-set! procedure? \"bad procedure ~S\" call-with-current-continuation open-file &i/o-filename-error location message \"cannot open file ~S\" 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 list %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 %use-utf8? string-split string-blit! string-titlecase string-titlecase! \"bad string ~S\" \" \\t\\n\" %string-use-utf8? string? string-length string->list substring integer? \"bad offset ~S\" string-mutable? \"changing the constant string ~S is not allowed\" zero? make-string \"bad starting index ~S\" \"bad ending index ~S\" char-alphabetic? char-upcase char-downcase length \"~a?\" 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 \"G\" symbol->string \"bad gensym prefix ~S\" number->string string->uninterned-symbol remove filter! remove! equal? delete delete! 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 eval eval-from-string *%program-args* :argv argv :program-name program-name dirname file-is-directory? make-directories make-directory ensure-directories-exist eq? 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 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 base64-encode-string base64-decode-string base64-encode base64-decode md5sum close-input-port \"cannot read file ~s\" md5sum-file ansi-color ansi-color-protect \"[\" \"m\" ((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\")) \";\" \"bad command ~S\" :interactive \"TERM\" getenv (\"rxvt\" \"xterm\" \"xterm-color\" \"linux\" \"cygwin\" \"cons25\") member do-color input-port? port->list \"bad port ~S\" eof-object? %port->list copy-port port->string port->sexp-list read-line port->string-list display newline print printerr flush-output-port eprintf printf fprintf \"&~a\" \"&~a?\" define-condition-type &error-message if not null? signal-error declare-new-error \"| \" exec exec-list argc string<? module? apropos \"bad module ~S\" module-symbols sort string-find? \"**** ~A\\n**** EXIT\\n\" exit die running-os cygwin-windows posixify-file-name #\\/ char=? \"/\" \".\" decompose-file-name \"^(.*)/(.+)$\" \"\\\\1\" regexp-replace string=? \"^(.*)/(.*)$\" \"\\\\2\" basename (unix cygwin-windows) memv windows #\\\\ #\\? file-separator make-path \"~A~A~A\" #\\. file-suffix file-prefix port-idle-register! %port-idle port-idle-unregister! port-idle-reset! expand-file-name %chmod bit-or write execute chmod \"bad option ~S\" mutex-lock! mutex-unlock! with-mutex receive compute-arity cond case-lambda \"bad clause ~S\" = 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 %parameter-dynenv-push! %parameter-dynenv-pop! parameterize require-extension \"requires at least one clause\" %has-feature? SRFI-0 srfi ok? x \"srfi-~a\" or \"extension ~S is absent\" make-keyword string->keyword get-environment-variable get-environment-variables *%autoloads* %try-load-tmp \":\" *path-separator* \"so\" \"ostk\" \"spi\" \"stk\" \"scm\" *load-suffixes* *load-verbose* *load-path* \"STKLOS_CONFDIR\" \"HOME\" \".stklos\" %stklos-conf-dir %stklos-conf-file build-path-from-shell-variable \"STKLOS_LOAD_PATH\" %library-prefix version \"pkg\" \"lib\" \"ext\" \"share\" \"stklos\" list? load-path \"bad list of path names ~S\" \"bad path name ~S\" \"bad list of suffixes ~S\" load-suffixes load-verbose current-loading-file \"%guess-pathname: trying ~S\\n\" file-exists? file-is-readable? \".?.?/\" regexp-match %guess-pathname try-load %primitive-try-load \";; Loading file ~S.\\n\" \";; File ~S loaded.\\n\" %try-load load \"cannot load file ~S\" %load find-path %%require require provide provided? require/provide warning-when-not-provided \"STKLOS_BUILDING\" \"WARNING: ~S was not provided~%\" require-library %%require4syntax require-for-syntax %%include include autoload-file remove-autoload! autoload \"~S has not been defined in ~S\" syntax-autoload (SCHEME) (srfi0-register-feature! srfi-0-feature-implementation-file) stklos STklos (utf-8 UTF-8) 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 srfi-17 srfi-18 srfi-22 srfi-23 srfi-26 \"srfi-26\" srfi-27 random \"srfi-27\" srfi-28 srfi-30 srfi-31 srfi-34 srfi-35 \"srfi-35\" srfi-36 \"srfi-36\" conditions srfi-38 srfi-39 parameters srfi-45 \"srfi-45\" srfi-48 srfi-55 srfi-59 \"srfi-59\" srfi-60 \"srfi-60\" srfi-62 srfi-66 \"srfi-66\" srfi-69 hash-tables \"srfi-69\" srfi-70 srfi-74 \"srfi-74\" srfi-88 srfi-89 \"srfi-89\" srfi-96 \"srfi-96\" srfi-98 *all-features* srfi0-register-feature! srfi-0-feature-implementation-file cond-expand \"no clause match\" \"invalid 'not' clause\" %srfi-0-expand (SRFI-0) \"srfi-0\" MBE \"cannot be used here. You must load the file \\\"full-syntax\\\" to access it:\" %not-implemented let-syntax ,args letrec-syntax some split \"list is too short\" 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 list->vector ... hyg:untag quasiquote (if begin) (set! define) letrec case unquote \"takes exactly one expression\" unquote-splicing \"invalid context within quasiquote\" list-tail \"%%\" mbe:position mbe:append-map mbe:matches-pattern? mbe:get-bindings mbe:expand-pattern \"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 \"\\\\\\\\[0-9]\" regexp-match-positions string->number \"cannot match \\\\~A in model\" list-ref 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 (eval disassemble compiler:time-display compiler:gen-line-number compiler:warn-use-undefined compiler:warn-use-undefined-postpone compiler:show-assembly-code compiler:inline-common-functions) *compiler-port* * fx+ fx- fx* fxdiv < <= > eqv? *inline-table* *inline-symbols* (%set-current-module %%set-current-module %%execute %%execute-handler) *always-inlined* *code-instr* *code-constants* *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 DEEP-LOCAL-REF DEEP-LOC-REF-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 GLOBAL-REF-PUSH PUSH-GLOBAL-REF INVOKE PUSH-GREF-INVOKE TAIL-INVOKE PUSH-GREF-TAIL-INV PREPARE-CALL PUSH-PREPARE-CALL GREF-INVOKE GREF-TAIL-INVOKE (LOCAL-REF0 LOCAL-REF1 LOCAL-REF2 LOCAL-REF3 LOCAL-REF4) LOCAL-REF0 LOCAL-REF0-PUSH LOCAL-REF1 LOCAL-REF1-PUSH LOCAL-REF2 LOCAL-REF2-PUSH LOCAL-REF3 LOCAL-REF3-PUSH LOCAL-REF4 LOCAL-REF4-PUSH 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) (DOCSTRG 1) (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) (LOCAL-REF0-PUSH 0) (LOCAL-REF1-PUSH 0) (LOCAL-REF2-PUSH 0) (LOCAL-REF3-PUSH 0) (LOCAL-REF4-PUSH 0) (GLOBAL-REF-PUSH 1) (UGLOBAL-REF-PUSH 1) (GREF-TAIL-INVOKE 2) (UGREF-TAIL-INVOKE 2) (PUSH-PREPARE-CALL 0) (PUSH-GLOBAL-REF 1) (PUSH-UGLOBAL-REF 1) (PUSH-GREF-INVOKE 2) (PUSH-UGREF-INVOKE 2) (PUSH-GREF-TAIL-INV 2) (PUSH-UGREF-TAIL-INV 2) (DEEP-LOC-REF-PUSH 1) (UNUSED-19 0) (UNUSED-18 0) (UNUSED-17 0) (UNUSED-16 0) (UNUSED-15 0) (UNUSED-14 0) (UNUSED-13 0) (UNUSED-12 0) (UNUSED-11 0) (UNUSED-10 0) (UNUSED-9 0) (UNUSED-8 0) (UNUSED-7 0) (UNUSED-6 0) (UNUSED-5 0) (UNUSED-4 0) (UNUSED-3 0) (IN-SINT-ADD2 1) (IN-SINT-SUB2 1) (IN-SINT-MUL2 1) (IN-SINT-DIV2 1) (UNUSED-29 0) (UNUSED-28 0) (UNUSED-27 0) (UNUSED-26 0) (UNUSED-25 0) (UNUSED-24 0) (UNUSED-23 0) (UNUSED-22 0) (UNUSED-21 0) (UNUSED-20 0) (DEEP-LOC-REF-FAR 1) (DEEP-LOC-SET-FAR 1) (CREATE-CLOSURE-FAR 2) (IN-FXADD2 0) (IN-FXSUB2 0) (IN-FXMUL2 0) (IN-FXDIV2 0) (IN-SINT-FXADD2 1) (IN-SINT-FXSUB2 1) (IN-SINT-FXMUL2 1) (IN-SINT-FXDIV2 1)) INSTRUCTION-SET \"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 CREATE-CLOSURE-FAR PUSH-HANDLER) use-address? string-upcase #\\space pretty-mnemonic \"Cannot decode ~S opcode\" find-instruction-infos CREATE-CLOSURE CREATE-CLOSURE-FAR \"No FAR version of instruction ~S\" find-far-codeop old+ make-vector small-integer-constant? fetch-constant \"Instr. using a big constant as 2nd operand ~S\" \"Instruction with more than 2 parameters ~S\" assemble quotient 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 *** \" getcwd string-index %path-without-cwd \"~A: \" %epair? \"~A:~A: \" %epair-file %epair-line \"~AError: ~A~A\\n\" compiler-error \"~Awarning: ~A~A\\n\" \"**** Warning;\\n~A~A\\n\" unbound symbol-bound? \"used outside of a quasiquote context\" compiler:time-display compiler:gen-line-number compiler:warn-use-undefined compiler:warn-use-undefined-postpone compiler:show-assembly-code compiler:inline-common-functions new-label emit emit-label expt compile-constant \"bad usage in ~S\" compile-quote *forward-globals* known-var? \"reference to undefined symbol ~S\" compiler-warn-undef 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 ~S\" compile-define symbol-in-env? GLOBAL-SET LOCAL-SET0 LOCAL-SET1 LOCAL-SET2 LOCAL-SET3 LOCAL-SET4 LOCAL-REF LOCAL-SET DEEP-LOCAL-SET DEEP-LOC-REF-FAR DEEP-LOC-SET-FAR 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 \"internal define-macro forbidden here ~S\" compile-define-macro compile-internal-define-macro %%set! compile-and compile-or compile-begin extend-env extend-current-env \"body is empty\" compile-body DOCSTRG compile-user-lambda ext-lambda-key-get 'lambda 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 DBG-VM generate-PREPARE-CALL 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 number? IN-SINT-ADD2 IN-ADD2 \"needs at least one argument\" IN-SINT-SUB2 IN-SUB2 IN-SINT-MUL2 IN-MUL2 IN-SINT-DIV2 IN-DIV2 (fx+ fx- fx* fxdiv) fixnum? (fx+ fx*) IN-SINT-FXADD2 IN-SINT-FXMUL2 IN-SINT-FXSUB2 IN-SINT-FXDIV2 IN-FXADD2 IN-FXSUB2 IN-FXMUL2 IN-FXDIV2 (= < > <= >=) O IN-CONS IN-CAR IN-CDR IN-NULLP IN-LIST IN-VREF IN-VSET IN-SREF IN-SSET \"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 'quasiquote backquotify 'unquote 'unquote-splicing compile-quasiquote PUSH-HANDLER POP-HANDLER compile-with-handler %read include-file \"bad include directive ~S\" compile-include compiler-maybe-do-autoload temporary-file-name compile-file %file-informations remove-file :nature source unknown find-file-informations :globals :expanders import-file-informations boolean? compile-require \"bad symbol ~S\" compile-%%pubsyntax \"*** Exception while required-for-syntax ~S\\n\" \"bad form ~S\" compile-require4syntax \"*** Exception on when-compile form of ~S\\n\" compile-when-compile %%when-compile when-compile when-load-and-compile %%label \"bad usage ~S\" compile-%%label %%goto compile-%%goto compile-%%source-pos %%source-pos END-OF-CODE %execute (STKLOS-COMPILER) STKLOS-OBJECT (find-class is-a? ensure-metaclass ensure-metaclass-with-supers ensure-class ensure-generic-function ensure-method add-method! object-eqv? object-equal? write-object display-object slot-unbound slot-missing slot-definition-name slot-definition-options slot-definition-allocation slot-definition-getter slot-definition-setter slot-definition-accessor slot-definition-init-form slot-definition-init-keyword slot-init-function class-slot-definition compute-get-n-set allocate-instance initialize make-instance make no-next-method no-applicable-method no-method change-class change-object-class shallow-clone deep-clone apply-generic apply-method apply-methods compute-applicable-methods method-more-specific? sort-applicable-methods method-procedure method-specializers method-generic-function method-specializers-equal? class-subclasses class-methods class-name class-direct-supers class-direct-subclasses class-precedence-list class-direct-methods class-direct-slots class-slots generic-function-name generic-function-methods generic-function-documentation slot-value) (STKLOS-OBJECT) 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 ??? %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 documentation generic-function-documentation 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\" :documentation ensure-generic-function define-generic :default %symbol-define %method-specializers-equal? method-specializers-equal? add-method-in-classes! remove-method-in-classes! compute-new-list-of-methods add-method! next-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 %find-inherited-get-n-set %direct-slot? :before-slot-ref :after-slot-ref :before-slot-set! :after-slot-set! %fast-slot-ref %fast-slot-set! %make-active-getter-n-setter 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 \"allocation type \\\"~S\\\" is unknown\" compute-slot-accessors %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 apply-method (<generic> <top> <top> <top>) %set-next-method! apply-methods (<generic> <list> <top>) apply-generic class-subclasses class-methods slot-value (<object> <top> <top>) %object-system-initialized %redefine-module-exports struct-type %time time? second micro-second 1000000.0 time-seconds \"bad time ~S\" time->seconds 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 #\\% #\\~ %seconds->string date->string \"date\" bit-and bit-xor #(#(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15) #(1 0 3 2 5 4 7 6 9 8 11 10 13 12 15 14) #(2 3 0 1 6 7 4 5 10 11 8 9 14 15 12 13) #(3 2 1 0 7 6 5 4 11 10 9 8 15 14 13 12) #(4 5 6 7 0 1 2 3 12 13 14 15 8 9 10 11) #(5 4 7 6 1 0 3 2 13 12 15 14 9 8 11 10) #(6 7 4 5 2 3 0 1 14 15 12 13 10 11 8 9) #(7 6 5 4 3 2 1 0 15 14 13 12 11 10 9 8) #(8 9 10 11 12 13 14 15 0 1 2 3 4 5 6 7) #(9 8 11 10 13 12 15 14 1 0 3 2 5 4 7 6) #(10 11 8 9 14 15 12 13 2 3 0 1 6 7 4 5) #(11 10 9 8 15 14 13 12 3 2 1 0 7 6 5 4) #(12 13 14 15 8 9 10 11 4 5 6 7 0 1 2 3) #(13 12 15 14 9 8 11 10 5 4 7 6 1 0 3 2) #(14 15 12 13 10 11 8 9 6 7 4 5 2 3 0 1) #(15 14 13 12 11 10 9 8 7 6 5 4 3 2 1 0)) #(#(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) #(0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1) #(0 0 2 2 0 0 2 2 0 0 2 2 0 0 2 2) #(0 1 2 3 0 1 2 3 0 1 2 3 0 1 2 3) #(0 0 0 0 4 4 4 4 0 0 0 0 4 4 4 4) #(0 1 0 1 4 5 4 5 0 1 0 1 4 5 4 5) #(0 0 2 2 4 4 6 6 0 0 2 2 4 4 6 6) #(0 1 2 3 4 5 6 7 0 1 2 3 4 5 6 7) #(0 0 0 0 0 0 0 0 8 8 8 8 8 8 8 8) #(0 1 0 1 0 1 0 1 8 9 8 9 8 9 8 9) #(0 0 2 2 0 0 2 2 8 8 10 10 8 8 10 10) #(0 1 2 3 0 1 2 3 8 9 10 11 8 9 10 11) #(0 0 0 0 4 4 4 4 8 8 8 8 12 12 12 12) #(0 1 0 1 4 5 4 5 8 9 8 9 12 13 12 13) #(0 0 2 2 4 4 6 6 8 8 10 10 12 12 14 14) #(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)) modulo bit-not bit-shift current-time \"bad timeout ~S\" %thread-timeout->seconds \"thread\" current-thread thread-name %build-error-location bold red \"**** Error \" blue \"(in thread ~S):\\n\" \"~A: ~A\\n\" clear \" (this error may be signaled again later)\\n\" %thread-end-exception-set! thread-handler-error-show %make-thread make-thread thread-sleep! \"cannot used #f as timeout\" %thread-sleep! thread-join! \"cannot join on myself (deadlock will occur)\" %thread-join! &thread-join-timeout %thread-end-exception &uncaught-exception reason %thread-end-result %mutex-lock! thread? &thread-abandonned-mutex %mutex-unlock! join-timeout-exception? abandoned-mutex-exception? &thread-terminated terminated-thread-exception? :: &condition (reason) make-condition-type uncaught-exception? uncaught-exception-reason make-external-function make-callback ((:void 0) (:char 1) (:short 2) (:ushort 3) (:int 4) (:uint 5) (:long 6) (:ulong 7) (:lonlong 8) (:ulonlong 9) (:float 10) (:double 11) (:boolean 12) (:pointer 13) (:string 14) (:int8 15) (:int16 16) (:int32 17) (:int64 18) (:obj 19)) define-external \"parameter of type :void are forbidden\" \"bad type name ~S\" \"bad parameter description: ~S\" %make-ext-func %make-callback :library-name \"cygwin1.dll\" :entry-name :return-type :void \"ffi\" make-list \"bad vector ~S\" char? \"all elements of the vector ~S must be characters\" list->string vector->string string->vector %make-uvector make-bytevector %uvector? bytevector? %uvector-length bytevector-length %uvector-ref bytevector-u8-ref %uvector-set! bytevector-u8-set! \"bad bytevector ~S\" bytevector-copy \"bytevector ~S is too long for copying it in ~S\" bytevector-copy! \"bad ending intex ~S\" bytevector-copy-partial \"bad destination index ~S\" \"cannot copy ~S bytes in ~S starting at index ~S\" bytevector-copy-partial! string-map \"bad character in ~S\" vector-map \"bad list of vectors ~S\" string-for-each vector-for-each 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 port-rewind rewind-file-port hash-table->list hash-table-put! hash-table-get hash-table-delete! hash-table-remove! \"Don't use anymore pragma, but compiler:warn-use-undef parameter\" stklos-pragma pragma define-reader-ctor remove-directory delete-directory current-seconds %build-path-from-shell-variable REPL (main-repl repl repl-prompt repl-make-prompt repl-display-prompt repl-prompt-use-color? repl-change-default-ports main-repl-hook) interactive-port? interactive? repl-level repl-backtrace default-in default-out default-err (help h ?) \"Available Commands:\\n- ,backtrace ,bt Show the stack when last error occurred\\n- ,quit ,q\\t Exit STklos\\n- ,help ,? ,h\\t This help\\n\" (quit q) (backtrace bt) %display-backtrace \"bad command name: ~S. Type ,help for some help\\n\" do-repl-command \" (near line ~a in file ~s)\" \"**** Error~A:\\n~A: ~A\\n\" \"\\t(type \\\"\" underline \",help\" \"\\\" for more information)\\n\" display-error-message &message repl-handler \"**** Unknown condition raised.\\n\" \"Condition type: ~A\\n\" struct-type-name \"Condition slots: ~S\\n\" \"**** The following non-condition was raised: ~S\\n\" repl-prompt repl-prompt-use-color? \"[~A] \" \"~A> \" module-name magenta black make-prompt repl-make-prompt display-prompt repl-display-prompt main-repl-hook :in G7607 :out G7608 :err G7609 repl-change-default-ports G7626 G7627 G7628 \"\\n\" \";; ~A\\n\" repl %initialize-signals \"STklos version ~A\\n\" \"Copyright (C) 1999-2012 Erick Gallesio - Universite de Nice <eg@unice.fr>\\n\" \"[~a/~a/~a/~a]\\n\" machine-type %thread-system :readline no-readline :use-utf8 utf8 no-utf8 \"* \" \" * \" \"* * \" normal %pre-exit main-repl READLINE (try-initialize-readline readline add-history read-history write-history read-with-history) readline add-history read-history write-history \"> \" read-with-history \"readline\" (:string) :pointer #eof cpointer->string free-bytes \"add_history\" \"read_history\" :int \"write_history\" \"el_set\" %get-symbol-address libedit try-initialize %shared-library-suffix \"libreadline.\" \"libedit.\" try-initialize-readline REPL-READLINE (REPL READLINE) (try-initialize-repl-with-readline) \"history\" \"\" \"\" nothing register-exit-function! #() %string->bytes #\\newline integer->char repl-readline-integration :line-editor try-initialize-repl-with-readline \"repl-readline\" (REPL REPL-READLINE) \"compfile\" describe \"describe\" ((match-case . \"bigmatch\") (match-lambda . \"bigmatch\")) %print-usage \"getopt\" ((parse-arguments . \"getopt\")) ((trace . \"trace\") (untrace . \"trace\")) pp \"pp\" pretty-print null-environment \"env\" scheme-report-environment interaction-environment help \"help\" lexer-next-token \"lex-rt\" ((interface . \"scmpkg-support\")) random-integer 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\" \"???\" \"**** Error while ~A ~S\\n\" \"\\t Where: in ~A\" \"\\tReason: ~A\\n\" \"EXIT\\n\" %simple-fatal-exception-handler SCHEME :no-init-file :load :file :sexpr :conf-dir :debug \"Warning: cannot create configuration directory ~S\\n\" \"stklosrc\" \"loading file\" \"executing file\" \"evaluating\")";
char* STk_boot_consts = "#(pair? car map apply map* cdr for-each* filter filter-map append append-map append! append-map! \"\" string->symbol \"~a\" format string-append symbol-append make-parameter stklos-debug-level :name \"STklos\" *%system-state-plist* compiler-known-globals memq register-new-global! *expander-list* *expander-list-src* *expander-published* assq expander? application-expander symbol? initial-expander set-cdr! install-expander! push-expander! caar delete-expander! expander-published-reset! symbol-value* compiler-warning STKLOS-COMPILER find-module reverse! assoc export-syntax \"cannot find source of syntax named ~S\" expander-published-sources expander-published-add! syntax-expand macro-expand macro-expand* %macro-expand* \"too many optional parameters: ~a\" error gensym module-imports \"symbol ``~S'' not found\" symbol-value %%set-current-module quote select-module %modules-stack current-module %create-module %module-create %module-restore raise %module-handler with-handler values void define-module reverse %module-imports-set! import \"module `~S' does not exist\" %module-import \"cannot find module ~S\" module-exports %symbol-alias \"symbol ~S is not exported from module ~S\" for-each %module-export %module-aliases cdar every \"bad import clause ~S\" begin call-with-values %module-exports-set! export \"bad symbol `~S'\" %%publish-syntax in-module 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 dynamic-wind %thread-dynwind-stack set-car! %thread-dynwind-stack-set! procedure? \"bad procedure ~S\" call-with-current-continuation open-file &i/o-filename-error location message \"cannot open file ~S\" 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 list %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 %use-utf8? string-split string-blit! string-titlecase string-titlecase! \"bad string ~S\" \" \\t\\n\" %string-use-utf8? string? string-length string->list substring integer? \"bad offset ~S\" string-mutable? \"changing the constant string ~S is not allowed\" zero? make-string \"bad starting index ~S\" \"bad ending index ~S\" char-alphabetic? char-upcase char-downcase length \"~a?\" 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 \"G\" symbol->string \"bad gensym prefix ~S\" number->string string->uninterned-symbol remove filter! remove! equal? delete delete! 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 eval eval-from-string *%program-args* :argv argv :program-name program-name dirname file-is-directory? make-directories make-directory ensure-directories-exist eq? 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 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 base64-encode-string base64-decode-string base64-encode base64-decode md5sum close-input-port \"cannot read file ~s\" md5sum-file ansi-color ansi-color-protect \"\\x1b;[\" \"m\" ((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\")) \";\" \"bad command ~S\" :interactive \"TERM\" getenv (\"rxvt\" \"xterm\" \"xterm-color\" \"linux\" \"cygwin\" \"cons25\") member do-color input-port? port->list \"bad port ~S\" eof-object? %port->list copy-port port->string port->sexp-list read-line port->string-list display newline print printerr flush-output-port eprintf printf fprintf \"&~a\" \"&~a?\" define-condition-type &error-message if not null? signal-error declare-new-error \"| \" exec exec-list argc string<? module? apropos \"bad module ~S\" module-symbols sort string-find? \"**** ~A\\n**** EXIT\\n\" exit die running-os cygwin-windows posixify-file-name #\\/ char=? \"/\" \".\" decompose-file-name \"^(.*)/(.+)$\" \"\\\\1\" regexp-replace string=? \"^(.*)/(.*)$\" \"\\\\2\" basename (unix cygwin-windows) memv windows #\\\\ #\\? file-separator make-path \"~A~A~A\" #\\. file-suffix file-prefix port-idle-register! %port-idle port-idle-unregister! port-idle-reset! expand-file-name %chmod bit-or write execute chmod \"bad option ~S\" mutex-lock! mutex-unlock! with-mutex receive compute-arity cond case-lambda \"bad clause ~S\" = 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 %parameter-dynenv-push! %parameter-dynenv-pop! parameterize require-extension \"requires at least one clause\" %has-feature? SRFI-0 srfi ok? x \"srfi-~a\" or \"extension ~S is absent\" make-keyword string->keyword get-environment-variable get-environment-variables *%autoloads* %try-load-tmp \":\" *path-separator* \"so\" \"ostk\" \"spi\" \"stk\" \"scm\" *load-suffixes* *load-verbose* *load-path* \"STKLOS_CONFDIR\" \"HOME\" \".stklos\" %stklos-conf-dir %stklos-conf-file build-path-from-shell-variable \"STKLOS_LOAD_PATH\" %library-prefix version \"pkg\" \"lib\" \"ext\" \"share\" \"stklos\" list? load-path \"bad list of path names ~S\" \"bad path name ~S\" \"bad list of suffixes ~S\" load-suffixes load-verbose current-loading-file \"%guess-pathname: trying ~S\\n\" file-exists? file-is-readable? \".?.?/\" regexp-match %guess-pathname try-load %primitive-try-load \";; Loading file ~S.\\n\" \";; File ~S loaded.\\n\" %try-load load \"cannot load file ~S\" %load find-path %%require require provide provided? require/provide warning-when-not-provided \"STKLOS_BUILDING\" \"WARNING: ~S was not provided~%\" require-library %%require4syntax require-for-syntax %%include include autoload-file remove-autoload! autoload \"~S has not been defined in ~S\" syntax-autoload (SCHEME) (srfi0-register-feature! srfi-0-feature-implementation-file) stklos STklos (utf-8 UTF-8) 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 srfi-17 srfi-18 srfi-22 srfi-23 srfi-26 \"srfi-26\" srfi-27 random \"srfi-27\" srfi-28 srfi-30 srfi-31 srfi-34 srfi-35 \"srfi-35\" srfi-36 \"srfi-36\" conditions srfi-38 srfi-39 parameters srfi-45 \"srfi-45\" srfi-48 srfi-55 srfi-59 \"srfi-59\" srfi-60 \"srfi-60\" srfi-62 srfi-66 \"srfi-66\" srfi-69 hash-tables \"srfi-69\" srfi-70 srfi-74 \"srfi-74\" srfi-88 srfi-89 \"srfi-89\" srfi-96 \"srfi-96\" srfi-98 *all-features* srfi0-register-feature! srfi-0-feature-implementation-file cond-expand \"no clause match\" \"invalid 'not' clause\" %srfi-0-expand (SRFI-0) \"srfi-0\" MBE \"cannot be used here. You must load the file \\\"full-syntax\\\" to access it:\" %not-implemented let-syntax ,args letrec-syntax some split \"list is too short\" 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 list->vector ... hyg:untag quasiquote (if begin) (set! define) letrec case unquote \"takes exactly one expression\" unquote-splicing \"invalid context within quasiquote\" list-tail \"%%\" mbe:position mbe:append-map mbe:matches-pattern? mbe:get-bindings mbe:expand-pattern \"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 \"\\\\\\\\[0-9]\" regexp-match-positions string->number \"cannot match \\\\~A in model\" list-ref 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 (eval disassemble compiler:time-display compiler:gen-line-number compiler:warn-use-undefined compiler:warn-use-undefined-postpone compiler:show-assembly-code compiler:inline-common-functions) *compiler-port* * fx+ fx- fx* fxdiv < <= > eqv? *inline-table* *inline-symbols* (%set-current-module %%set-current-module %%execute %%execute-handler) *always-inlined* *code-instr* *code-constants* *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 DEEP-LOCAL-REF DEEP-LOC-REF-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 GLOBAL-REF-PUSH PUSH-GLOBAL-REF INVOKE PUSH-GREF-INVOKE TAIL-INVOKE PUSH-GREF-TAIL-INV PREPARE-CALL PUSH-PREPARE-CALL GREF-INVOKE GREF-TAIL-INVOKE (LOCAL-REF0 LOCAL-REF1 LOCAL-REF2 LOCAL-REF3 LOCAL-REF4) LOCAL-REF0 LOCAL-REF0-PUSH LOCAL-REF1 LOCAL-REF1-PUSH LOCAL-REF2 LOCAL-REF2-PUSH LOCAL-REF3 LOCAL-REF3-PUSH LOCAL-REF4 LOCAL-REF4-PUSH 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) (DOCSTRG 1) (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) (LOCAL-REF0-PUSH 0) (LOCAL-REF1-PUSH 0) (LOCAL-REF2-PUSH 0) (LOCAL-REF3-PUSH 0) (LOCAL-REF4-PUSH 0) (GLOBAL-REF-PUSH 1) (UGLOBAL-REF-PUSH 1) (GREF-TAIL-INVOKE 2) (UGREF-TAIL-INVOKE 2) (PUSH-PREPARE-CALL 0) (PUSH-GLOBAL-REF 1) (PUSH-UGLOBAL-REF 1) (PUSH-GREF-INVOKE 2) (PUSH-UGREF-INVOKE 2) (PUSH-GREF-TAIL-INV 2) (PUSH-UGREF-TAIL-INV 2) (DEEP-LOC-REF-PUSH 1) (UNUSED-19 0) (UNUSED-18 0) (UNUSED-17 0) (UNUSED-16 0) (UNUSED-15 0) (UNUSED-14 0) (UNUSED-13 0) (UNUSED-12 0) (UNUSED-11 0) (UNUSED-10 0) (UNUSED-9 0) (UNUSED-8 0) (UNUSED-7 0) (UNUSED-6 0) (UNUSED-5 0) (UNUSED-4 0) (UNUSED-3 0) (IN-SINT-ADD2 1) (IN-SINT-SUB2 1) (IN-SINT-MUL2 1) (IN-SINT-DIV2 1) (UNUSED-29 0) (UNUSED-28 0) (UNUSED-27 0) (UNUSED-26 0) (UNUSED-25 0) (UNUSED-24 0) (UNUSED-23 0) (UNUSED-22 0) (UNUSED-21 0) (UNUSED-20 0) (DEEP-LOC-REF-FAR 1) (DEEP-LOC-SET-FAR 1) (CREATE-CLOSURE-FAR 2) (IN-FXADD2 0) (IN-FXSUB2 0) (IN-FXMUL2 0) (IN-FXDIV2 0) (IN-SINT-FXADD2 1) (IN-SINT-FXSUB2 1) (IN-SINT-FXMUL2 1) (IN-SINT-FXDIV2 1)) INSTRUCTION-SET \"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 CREATE-CLOSURE-FAR PUSH-HANDLER) use-address? string-upcase #\\space pretty-mnemonic \"Cannot decode ~S opcode\" find-instruction-infos CREATE-CLOSURE CREATE-CLOSURE-FAR \"No FAR version of instruction ~S\" find-far-codeop old+ make-vector small-integer-constant? fetch-constant \"Instr. using a big constant as 2nd operand ~S\" \"Instruction with more than 2 parameters ~S\" assemble quotient 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 *** \" getcwd string-index %path-without-cwd \"~A: \" %epair? \"~A:~A: \" %epair-file %epair-line \"~AError: ~A~A\\n\" compiler-error \"~Awarning: ~A~A\\n\" \"**** Warning;\\n~A~A\\n\" unbound symbol-bound? \"used outside of a quasiquote context\" compiler:time-display compiler:gen-line-number compiler:warn-use-undefined compiler:warn-use-undefined-postpone compiler:show-assembly-code compiler:inline-common-functions new-label emit emit-label expt compile-constant \"bad usage in ~S\" compile-quote *forward-globals* known-var? \"reference to undefined symbol ~S\" compiler-warn-undef 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 ~S\" compile-define symbol-in-env? GLOBAL-SET LOCAL-SET0 LOCAL-SET1 LOCAL-SET2 LOCAL-SET3 LOCAL-SET4 LOCAL-REF LOCAL-SET DEEP-LOCAL-SET DEEP-LOC-REF-FAR DEEP-LOC-SET-FAR 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 \"internal define-macro forbidden here ~S\" compile-define-macro compile-internal-define-macro %%set! compile-and compile-or compile-begin extend-env extend-current-env \"body is empty\" compile-body DOCSTRG compile-user-lambda ext-lambda-key-get 'lambda 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 DBG-VM generate-PREPARE-CALL 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 number? IN-SINT-ADD2 IN-ADD2 \"needs at least one argument\" IN-SINT-SUB2 IN-SUB2 IN-SINT-MUL2 IN-MUL2 IN-SINT-DIV2 IN-DIV2 (fx+ fx- fx* fxdiv) fixnum? (fx+ fx*) IN-SINT-FXADD2 IN-SINT-FXMUL2 IN-SINT-FXSUB2 IN-SINT-FXDIV2 IN-FXADD2 IN-FXSUB2 IN-FXMUL2 IN-FXDIV2 (= < > <= >=) O IN-CONS IN-CAR IN-CDR IN-NULLP IN-LIST IN-VREF IN-VSET IN-SREF IN-SSET \"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 'quasiquote backquotify 'unquote 'unquote-splicing compile-quasiquote PUSH-HANDLER POP-HANDLER compile-with-handler %read include-file \"bad include directive ~S\" compile-include compiler-maybe-do-autoload temporary-file-name compile-file %file-informations remove-file :nature source unknown find-file-informations :globals :expanders import-file-informations boolean? compile-require \"bad symbol ~S\" compile-%%pubsyntax \"*** Exception while required-for-syntax ~S\\n\" \"bad form ~S\" compile-require4syntax \"*** Exception on when-compile form of ~S\\n\" compile-when-compile %%when-compile when-compile when-load-and-compile %%label \"bad usage ~S\" compile-%%label %%goto compile-%%goto compile-%%source-pos %%source-pos END-OF-CODE %execute (STKLOS-COMPILER) STKLOS-OBJECT (find-class is-a? ensure-metaclass ensure-metaclass-with-supers ensure-class ensure-generic-function ensure-method add-method! object-eqv? object-equal? write-object display-object slot-unbound slot-missing slot-definition-name slot-definition-options slot-definition-allocation slot-definition-getter slot-definition-setter slot-definition-accessor slot-definition-init-form slot-definition-init-keyword slot-init-function class-slot-definition compute-get-n-set allocate-instance initialize make-instance make no-next-method no-applicable-method no-method change-class change-object-class shallow-clone deep-clone apply-generic apply-method apply-methods compute-applicable-methods method-more-specific? sort-applicable-methods method-procedure method-specializers method-generic-function method-specializers-equal? class-subclasses class-methods class-name class-direct-supers class-direct-subclasses class-precedence-list class-direct-methods class-direct-slots class-slots generic-function-name generic-function-methods generic-function-documentation slot-value) (STKLOS-OBJECT) 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 ??? %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 documentation generic-function-documentation 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\" :documentation ensure-generic-function define-generic :default %symbol-define %method-specializers-equal? method-specializers-equal? add-method-in-classes! remove-method-in-classes! compute-new-list-of-methods add-method! next-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 %find-inherited-get-n-set %direct-slot? :before-slot-ref :after-slot-ref :before-slot-set! :after-slot-set! %fast-slot-ref %fast-slot-set! %make-active-getter-n-setter 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 \"allocation type \\\"~S\\\" is unknown\" compute-slot-accessors %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 apply-method (<generic> <top> <top> <top>) %set-next-method! apply-methods (<generic> <list> <top>) apply-generic class-subclasses class-methods slot-value (<object> <top> <top>) %object-system-initialized %redefine-module-exports struct-type %time time? second micro-second 1000000.0 time-seconds \"bad time ~S\" time->seconds 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 #\\% #\\~ %seconds->string date->string \"date\" bit-and bit-xor #(#(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15) #(1 0 3 2 5 4 7 6 9 8 11 10 13 12 15 14) #(2 3 0 1 6 7 4 5 10 11 8 9 14 15 12 13) #(3 2 1 0 7 6 5 4 11 10 9 8 15 14 13 12) #(4 5 6 7 0 1 2 3 12 13 14 15 8 9 10 11) #(5 4 7 6 1 0 3 2 13 12 15 14 9 8 11 10) #(6 7 4 5 2 3 0 1 14 15 12 13 10 11 8 9) #(7 6 5 4 3 2 1 0 15 14 13 12 11 10 9 8) #(8 9 10 11 12 13 14 15 0 1 2 3 4 5 6 7) #(9 8 11 10 13 12 15 14 1 0 3 2 5 4 7 6) #(10 11 8 9 14 15 12 13 2 3 0 1 6 7 4 5) #(11 10 9 8 15 14 13 12 3 2 1 0 7 6 5 4) #(12 13 14 15 8 9 10 11 4 5 6 7 0 1 2 3) #(13 12 15 14 9 8 11 10 5 4 7 6 1 0 3 2) #(14 15 12 13 10 11 8 9 6 7 4 5 2 3 0 1) #(15 14 13 12 11 10 9 8 7 6 5 4 3 2 1 0)) #(#(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) #(0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1) #(0 0 2 2 0 0 2 2 0 0 2 2 0 0 2 2) #(0 1 2 3 0 1 2 3 0 1 2 3 0 1 2 3) #(0 0 0 0 4 4 4 4 0 0 0 0 4 4 4 4) #(0 1 0 1 4 5 4 5 0 1 0 1 4 5 4 5) #(0 0 2 2 4 4 6 6 0 0 2 2 4 4 6 6) #(0 1 2 3 4 5 6 7 0 1 2 3 4 5 6 7) #(0 0 0 0 0 0 0 0 8 8 8 8 8 8 8 8) #(0 1 0 1 0 1 0 1 8 9 8 9 8 9 8 9) #(0 0 2 2 0 0 2 2 8 8 10 10 8 8 10 10) #(0 1 2 3 0 1 2 3 8 9 10 11 8 9 10 11) #(0 0 0 0 4 4 4 4 8 8 8 8 12 12 12 12) #(0 1 0 1 4 5 4 5 8 9 8 9 12 13 12 13) #(0 0 2 2 4 4 6 6 8 8 10 10 12 12 14 14) #(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)) modulo bit-not bit-shift current-time \"bad timeout ~S\" %thread-timeout->seconds \"thread\" current-thread thread-name %build-error-location bold red \"**** Error \" blue \"(in thread ~S):\\n\" \"~A: ~A\\n\" clear \" (this error may be signaled again later)\\n\" %thread-end-exception-set! thread-handler-error-show %make-thread make-thread thread-sleep! \"cannot used #f as timeout\" %thread-sleep! thread-join! \"cannot join on myself (deadlock will occur)\" %thread-join! &thread-join-timeout %thread-end-exception &uncaught-exception reason %thread-end-result %mutex-lock! thread? &thread-abandonned-mutex %mutex-unlock! join-timeout-exception? abandoned-mutex-exception? &thread-terminated terminated-thread-exception? :: &condition (reason) make-condition-type uncaught-exception? uncaught-exception-reason make-external-function make-callback ((:void 0) (:char 1) (:short 2) (:ushort 3) (:int 4) (:uint 5) (:long 6) (:ulong 7) (:lonlong 8) (:ulonlong 9) (:float 10) (:double 11) (:boolean 12) (:pointer 13) (:string 14) (:int8 15) (:int16 16) (:int32 17) (:int64 18) (:obj 19)) define-external \"parameter of type :void are forbidden\" \"bad type name ~S\" \"bad parameter description: ~S\" %make-ext-func %make-callback :library-name \"cygwin1.dll\" :entry-name :return-type :void \"ffi\" make-list \"bad vector ~S\" char? \"all elements of the vector ~S must be characters\" list->string vector->string string->vector %make-uvector make-bytevector %uvector? bytevector? %uvector-length bytevector-length %uvector-ref bytevector-u8-ref %uvector-set! bytevector-u8-set! \"bad bytevector ~S\" bytevector-copy \"bytevector ~S is too long for copying it in ~S\" bytevector-copy! \"bad ending intex ~S\" bytevector-copy-partial \"bad destination index ~S\" \"cannot copy ~S bytes in ~S starting at index ~S\" bytevector-copy-partial! string-map \"bad character in ~S\" vector-map \"bad list of vectors ~S\" string-for-each vector-for-each 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 port-rewind rewind-file-port hash-table->list hash-table-put! hash-table-get hash-table-delete! hash-table-remove! \"Don't use anymore pragma, but compiler:warn-use-undef parameter\" stklos-pragma pragma define-reader-ctor remove-directory delete-directory current-seconds %build-path-from-shell-variable REPL (main-repl repl repl-prompt repl-make-prompt repl-display-prompt repl-prompt-use-color? repl-change-default-ports main-repl-hook) interactive-port? interactive? repl-level repl-backtrace default-in default-out default-err (help h ?) \"Available Commands:\\n- ,backtrace ,bt Show the stack when last error occurred\\n- ,quit ,q\\t Exit STklos\\n- ,help ,? ,h\\t This help\\n\" (quit q) (backtrace bt) %display-backtrace \"bad command name: ~S. Type ,help for some help\\n\" do-repl-command \" (near line ~a in file ~s)\" \"**** Error~A:\\n~A: ~A\\n\" \"\\t(type \\\"\" underline \",help\" \"\\\" for more information)\\n\" display-error-message &message repl-handler \"**** Unknown condition raised.\\n\" \"Condition type: ~A\\n\" struct-type-name \"Condition slots: ~S\\n\" \"**** The following non-condition was raised: ~S\\n\" repl-prompt repl-prompt-use-color? \"[~A] \" \"~A> \" module-name magenta black make-prompt repl-make-prompt display-prompt repl-display-prompt main-repl-hook :in G7607 :out G7608 :err G7609 repl-change-default-ports G7626 G7627 G7628 \"\\n\" \";; ~A\\n\" repl %initialize-signals \"STklos version ~A\\n\" \"Copyright (C) 1999-2012 Erick Gallesio - Universite de Nice <eg@unice.fr>\\n\" \"[~a/~a/~a/~a]\\n\" machine-type %thread-system :readline no-readline :use-utf8 utf8 no-utf8 \"* \" \" * \" \"* * \" normal %pre-exit main-repl READLINE (try-initialize-readline readline add-history read-history write-history read-with-history) readline add-history read-history write-history \"> \" read-with-history \"readline\" (:string) :pointer #eof cpointer->string free-bytes \"add_history\" \"read_history\" :int \"write_history\" \"el_set\" %get-symbol-address libedit try-initialize %shared-library-suffix \"libreadline.\" \"libedit.\" try-initialize-readline REPL-READLINE (REPL READLINE) (try-initialize-repl-with-readline) \"history\" \"\\x01;\" \"\\x02;\" nothing register-exit-function! #() %string->bytes #\\newline integer->char repl-readline-integration :line-editor try-initialize-repl-with-readline \"repl-readline\" (REPL REPL-READLINE) \"compfile\" describe \"describe\" ((match-case . \"bigmatch\") (match-lambda . \"bigmatch\")) %print-usage \"getopt\" ((parse-arguments . \"getopt\")) ((trace . \"trace\") (untrace . \"trace\")) pp \"pp\" pretty-print null-environment \"env\" scheme-report-environment interaction-environment help \"help\" lexer-next-token \"lex-rt\" ((interface . \"scmpkg-support\")) random-integer 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\" \"???\" \"**** Error while ~A ~S\\n\" \"\\t Where: in ~A\" \"\\tReason: ~A\\n\" \"EXIT\\n\" %simple-fatal-exception-handler SCHEME :no-init-file :load :file :sexpr :conf-dir :debug \"Warning: cannot create configuration directory ~S\\n\" \"stklosrc\" \"loading file\" \"executing file\" \"evaluating\")";
STk_instr STk_boot_code [] = {
0x23,
......
No preview for this file type
/*
* p r i n t . c -- writing stuff
*
* Copyright © 1993-2011 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
* Copyright © 1993-2012 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: ??-Oct-1993 ??:??
* Last file update: 23-Jul-2011 12:12 (eg)
* Last file update: 26-Feb-2012 18:25 (eg)
*
*/
#include <ctype.h>
......@@ -88,11 +88,12 @@ static void Inline printkeyword(SCM key, SCM port, int mode)
}
static char printhexa(int x)
static Inline char printhexa(int x)
{
return (x >= 10) ? (x - 10 + 'a') : (x + '0');
}
static void printstring(SCM s, SCM port, int mode)
{
if (mode == DSP_MODE) {
......@@ -122,18 +123,27 @@ static void printstring(SCM s, SCM port, int mode)
case '\v' : *buff++ = '\\'; *buff++ = 'v'; break;
case '"' :
case '\\' : *buff++ = '\\'; *buff++ = *p; break;
default : if (STk_use_utf8)
*buff++ = *p;
else {
if ((((unsigned char) *p) & 0177) < (unsigned char) ' ') {
/* Non printable character (It works only for ISO 8859-x !!) */
*buff++ = '\\';
*buff++ = 'x';
*buff++ = printhexa((unsigned char) *p / 16);
*buff++ = printhexa((unsigned char) *p % 16);
default : {
int printable;
if (STk_use_utf8)
printable =
(((unsigned) *p) >= (unsigned) ' ');
else
printable =
((((unsigned char) *p) & 0177) >= (unsigned char) ' ');
if (printable)
*buff++ = *p;
else {
/* Non printable char. (It works only for char < 0xFF !!) */
*buff++ = '\\';
*buff++ = 'x';
*buff++ = printhexa((unsigned char) *p / 16);
*buff++ = printhexa((unsigned char) *p % 16);
*buff++ = ';';
}
}
else *buff++ = *p;
}
}
}
*buff++ = '"';
......
/*
* r e a d . c -- reading stuff
*
* Copyright © 1993-2011 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
* Copyright © 1993-2012 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
......@@ -20,7 +20,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: ??-Oct-1993 ??:??
* Last file update: 8-Oct-2011 16:09 (eg)
* Last file update: 26-Feb-2012 18:51 (eg)
*
*/
......@@ -92,9 +92,12 @@ static void error_bad_dotted_list(SCM port)
signal_error(port, "bad dotted list", STk_nil);
}
static void error_bad_inline_hexa_sequence(SCM port)
static void error_bad_inline_hexa_sequence(SCM port, char *buffer, int x)
{
signal_error(port, "bad inline hexa sequence", STk_nil);
char message[200];
snprintf(message, 200, "bad inline hexa sequence (%s %d) on port ~S", buffer, x);
signal_error(port, message, port);
}
static void warning_parenthesis(SCM port)
......@@ -133,12 +136,12 @@ static int read_hex_sequence(SCM port, char* utf8_seq)
buffer[i] = '\0';
if (c != ';')
error_bad_inline_hexa_sequence(port);
error_bad_inline_hexa_sequence(port, buffer, 1);
else {
val = strtol(buffer, &end, 16);
if (val == LONG_MIN || val == LONG_MAX || *end != ';')
error_bad_inline_hexa_sequence(port);
error_bad_inline_hexa_sequence(port, buffer, 2);
else
if (STk_use_utf8) {
int len = STk_char2utf8(val, utf8_seq);
......@@ -153,7 +156,7 @@ static int read_hex_sequence(SCM port, char* utf8_seq)
}
/* if we are here , we have an error */
error_bad_inline_hexa_sequence(port);
error_bad_inline_hexa_sequence(port, buffer,3);
return 0;
}
......@@ -304,7 +307,7 @@ static SCM read_char(SCM port, int c)
for( ; ; ) {
tok[j++] = c;
c = STk_getc(port);
if (c == EOF || ((c <=0x80) && isspace((unsigned char)c)))
if (c == EOF || ((c <=0x80) && isspace((unsigned char)c)))
/* (c < 0x80) is for MacOs */
break;
if (strchr("()[]'`,;\"", c)) {
......
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 28-Dec-1999 21:19 (eg)
* Last file update: 1-Jan-2012 19:33 (eg)
* Last file update: 26-Feb-2012 23:32 (eg)
*/
#include <stklos.h>
......@@ -181,15 +181,15 @@ int main(int argc, char *argv[])
argv += ret;
/* See if we use UTF8 encoding */
if (!setlocale(LC_CTYPE, "")) {
if (!setlocale(LC_ALL, "")) {
fprintf(stderr, "Can't set the specified locale! "
"Check LANG, LC_CTYPE, LC_ALL.\n");
return 1;
} else {
if (STk_use_utf8 == -1) {
/* user didn't force the encoding. Determine it from environment */
STk_use_utf8 = (strcmp(nl_langinfo(CODESET), "UTF-8") == 0);
}
}
if (STk_use_utf8 == -1) {
/* user didn't force the encoding. Determine it from environment */
STk_use_utf8 = (strcmp(nl_langinfo(CODESET), "UTF-8") == 0);
}
/* Hack: to give the illusion that there is no VM under the scene */
......
......@@ -16,7 +16,7 @@
*
* Author: Erick Gallesio [eg@kaolin.unice.fr]
* Creation date: 29-Mar-1994 10:57
* Last file update: 2-Jan-2012 13:23 (eg)
* Last file update: 26-Feb-2012 23:14 (eg)
*/
#include <unistd.h>
......@@ -26,6 +26,7 @@
#include <fcntl.h>
#include <dirent.h>
#include <time.h>
#include <locale.h>
#include "stklos.h"
#include "struct.h"
......@@ -1144,6 +1145,14 @@ DEFINE_PRIMITIVE("%big-endian?", big_endianp, subr0, (void))
}
DEFINE_PRIMITIVE("%get-locale", get_locale, subr0, (void))
{
char *str = setlocale(LC_ALL, NULL);
return str? STk_Cstring2string(str) : STk_false;
}
int STk_init_system(void)
{
SCM current_module = STk_STklos_module;
......@@ -1222,5 +1231,6 @@ int STk_init_system(void)
ADD_PRIMITIVE(pause);
ADD_PRIMITIVE(big_endianp);
ADD_PRIMITIVE(get_locale);
return TRUE;
}
......@@ -2,7 +2,7 @@
#
# Author: Erick Gallesio [eg@essi.fr]
# Creation date: 23-May-2005 14:52 (eg)
# Last file update: 23-Oct-2010 11:54 (eg)
# Last file update: 26-Feb-2012 19:04 (eg)
all:
@echo "Use \"make test\" for testing STklos."
......@@ -10,7 +10,7 @@ all:
check: test
test:
@../src/stklos -f do-test.stk
@../src/stklos --utf8-encoding=yes -f do-test.stk
clean:
rm -f TEST.LOG data *~
......@@ -19,5 +19,3 @@ distclean: clean
rm -f Makefile
install:
......@@ -19,7 +19,7 @@
#
# Author: Erick Gallesio [eg@essi.fr]
# Creation date: 23-May-2005 14:52 (eg)
# Last file update: 23-Oct-2010 11:54 (eg)
# Last file update: 26-Feb-2012 19:04 (eg)
VPATH = @srcdir@
pkgdatadir = $(datadir)/@PACKAGE@
pkgincludedir = $(includedir)/@PACKAGE@
......@@ -360,7 +360,7 @@ all:
check: test
test:
@../src/stklos -f do-test.stk
@../src/stklos --utf8-encoding=yes -f do-test.stk
clean:
rm -f TEST.LOG data *~
......
;;;; -*- coding utf-8 -*-
;;;; test-utf8.stk -- Test of UTF-8 strings
;;;;
;;;; Copyright © 2011 Erick Gallesio - Polytech'Nice-Sophia <eg@unice.fr>
;;;; Copyright © 2011-2012 Erick Gallesio - Polytech'Nice-Sophia <eg@unice.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
......@@ -21,15 +21,22 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 27-May-2011 23:35 (eg)
;;;; Last file update: 8-Oct-2011 22:13 (eg)
;;;; Last file update: 26-Feb-2012 23:33 (eg)
;;;;
(require "test")
(define *lang-is-utf8?* (let ((lang (getenv "LANG")))
(and lang
(or (string-find? "UTF8" lang)
(string-find? "utf8" lang)))))
;;(define *lang-is-utf8?* (let ((lang (getenv "LANG")))
;; (and lang
;; (or (string-find? "UTF8" lang)
;; (string-find? "utf8" lang)))))
(define *lang-is-utf8?* #t) ;; In fact, we force it, since it must work even if
;; user doesn't use UTF-8 when launch the test.
;; STklos is now called with with -u=1 option
(define *is-C?* (equal? (%get-locale) "C"))
(test-section "Unicode Characters")
;;------------------------------------------------------------------
......@@ -95,11 +102,11 @@
(test "gambit.8" #\xDF (char-foldcase #\xDF))
(test "gambit.9" #\x3A3 (char-upcase #\x3A3))
(when *lang-is-utf8?* (test "gambit.10" #\x3C3 (char-downcase #\x3A3)))
(unless *is-C?* (test "gambit.10" #\x3C3 (char-downcase #\x3A3)))
#;(test "gambit.11" #\x3A3 (char-titlecase #\x3A3)) ;; not R7
(when *lang-is-utf8?* (test "gambit.12" #\x3C3 (char-foldcase #\x3A3)))
(when *lang-is-utf8?* (test "gambit.13" #\x3A3 (char-upcase #\x3C2)))
(unless *is-C?*
(test "gambit.12" #\x3C3 (char-foldcase #\x3A3))
(test "gambit.13" #\x3A3 (char-upcase #\x3C2)))
(test "gambit.14" #\x3C2 (char-downcase #\x3C2))
#;(test "gambit.15" #\x3A3 (char-titlecase #\x3C2)) ;; not R7
(test "gambit.16" #\x3C3 (char-foldcase #\x3C2))
......@@ -133,10 +140,13 @@
(test "gambit.42" #f (char-whitespace? #\a))
(test "gambit.43" #f (char-upper-case? #\a))
(test "gambit.44" #t (char-upper-case? #\A))
(when *lang-is-utf8?* (test "gambit.45" #t (char-upper-case? #\x3A3)))
(unless *is-C?*
(test "gambit.45" #t (char-upper-case? #\x3A3)))
(test "gambit.46" #t (char-lower-case? #\a))
(test "gambit.47" #f (char-lower-case? #\A))
(when *lang-is-utf8?* (test "gambit.48" #t (char-lower-case? #\x3C3)))
(unless *is-C?*
(test "gambit.48" #t (char-lower-case? #\x3C3)))
#;(test "gambit.49" #t (char-lower-case? #\x00AA)) ;; not clear
#;(test "gambit.50" #f (char-title-case? #\a)) ;; Not R7
#;(test "gambit.51" #f (char-title-case? #\A)) ;; Not R7
......@@ -160,7 +170,8 @@
#;(test "gambit.66" "strasse" (string-foldcase "Stra\xDF;e")) ;; not R7
(test "gambit.67" "strasse" (string-downcase "STRASSE"))
(when *lang-is-utf8?* (test "gambit.68" "\x3C3;" (string-downcase "\x3A3;")))
(unless *is-C?*
(test "gambit.68" "\x3C3;" (string-downcase "\x3A3;")))
(test "gambit.69" "\x39E;\x391;\x39F;\x3A3;"
(string-upcase "\x39E;\x391;\x39F;\x3A3;"))
......@@ -170,7 +181,7 @@
(string-downcase "\x39E;\x391;\x39F;\x3A3;\x3A3;"))
#;(test "gambit.72" "\x3BE;\x3B1;\x3BF;\x3C2; \x3C3;"
(string-downcase "\x39E;\x391;\x39F;\x3A3; \x3A3;")) ;; not R7
(when *lang-is-utf8?*
(unless *is-C?*
(test "gambit.73" "\x3BE;\x3B1;\x3BF;\x3C3;"
(string-foldcase "\x39E;\x391;\x39F;\x3A3;"))
(test "gambit.74" "\x39E;\x391;\x39F;\x3A3;"
......@@ -206,7 +217,7 @@
#;(test "gambit.96" #t (string-ci=? "Stra\xDF;e" "STRASSE")) ;; Not R7
#;(test "gambit.97" #t (string-ci=? "\x39E;\x391;\x39F;\x3A3;" ;; Not R7
"\x3BE;\x3B1;\x3BF;\x3C2;"))
(when *lang-is-utf8?*
(unless *is-C?*
(test "gambit.98" #t (string-ci=? "\x39E;\x391;\x39F;\x3A3;"
"\x3BE;\x3B1;\x3BF;\x3C3;")))
......
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