Commit ade1ed76 authored by Erick Gallesio's avatar Erick Gallesio

Fixed a problem with macros with great areity (> 12)

parent 777373c3
;;;;
;;;; boot.stk -- Default boot file
;;;;
;;;; Copyright 2000-2006 Erick Gallesio - I3S-CNRS/ESSI <[email protected]>
;;;; Copyright 2000-2007 Erick Gallesio - I3S-CNRS/ESSI <[email protected]>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [[email protected]]
;;;; Creation date: 01-Jan-2000 15:04 (eg)
;;;; Last file update: 21-Dec-2006 23:51 (eg)
;;;; Last file update: 1-Feb-2007 18:57 (eg)
;;;;
(include "runtime.stk") ; Definition necessary for the bootstrap
......@@ -53,7 +53,7 @@
(autoload "pp" pp pretty-print)
(autoload "env" null-environment scheme-report-environment
interaction-environment)
(syntax-autoload "snow-support" package*)
;(syntax-autoload "snow-support" package*)
(autoload "srfi-27" random-integer random-real)
(syntax-autoload "srfi-34" with-exception-handler guard)
(syntax-autoload "srfi-35" define-condition-type condition)
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [[email protected]]
;;;; Creation date: 26-Feb-2000 10:47 (eg)
;;;; Last file update: 25-Jan-2007 22:22 (eg)
;;;; Last file update: 3-Feb-2007 16:01 (eg)
;;;;
(define-module STKLOS-COMPILER
......@@ -349,7 +349,7 @@ doc>
(proc (caddr l))
(expander `(lambda (form e) (apply ,proc (cdr form)))))
;; Install expander for further compilation
(install-expander! name (eval expander) proc)))))
(install-expander! name (eval expander) #f)))))
;;;;
......@@ -1419,7 +1419,6 @@ doc>
(let* ((name (car x))
(proc (cdr x))
(expander `(lambda (form e) (apply ,proc (cdr form)))))
(eprintf "DEBUG: create back macro ~S\n" name)
(install-expander! name (eval expander) proc)))
(key-get infos :expanders '()))
)))
......
;;;;
;;;; peephole.stk -- Peephole Optimiser fro the STklos VM
;;;;
;;;; Copyright 2001-2006 Erick Gallesio - I3S-CNRS/ESSI <[email protected]>
;;;; Copyright 2001-2007 Erick Gallesio - I3S-CNRS/ESSI <[email protected]>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [[email protected]]
;;;; Creation date: 17-Mar-2001 20:32 (eg)
;;;; Last file update: 27-Sep-2006 13:41 (eg)
;;;; Last file update: 3-Feb-2007 15:18 (eg)
;;;;
; ======================================================================
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [[email protected]]
;;;; Creation date: 15-Mar-2001 22:49 (eg)
;;;; Last file update: 25-Jan-2007 21:23 (eg)
;;;; Last file update: 1-Feb-2007 22:39 (eg)
;;;;
......@@ -67,8 +67,9 @@
(define (install-expander! id proc code)
(set! *expander-list* (cons (cons id proc) *expander-list*))
;; Keep the code associated to the macro to save it in byte-code header
(set! *expander-list-src* (cons (cons id code) *expander-list-src*)))
(when code
;; Global macro: Keep the macro code to save it in byte-code header
(set! *expander-list-src* (cons (cons id code) *expander-list-src*))))
;;;
;;; Expander-list-src management
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 18-Jan-2007 16:59 (eg)
;;;; Last file update: 1-Feb-2007 11:00 (eg)
;;;; Last file update: 1-Feb-2007 15:55 (eg)
;;;;
......@@ -76,6 +76,27 @@
(else
(die (format "bad package* clause ~S" pkg*)))))))
;; ----------------------------------------------------------------------
;; local-snowfort-add-tuning! ...
;; ----------------------------------------------------------------------
(define (local-snowfort-add-tuning! snowball package version tuning directory)
(unless (equal? tuning "stklos")
(die "Cannot manage non STklos tunings"))
(when (> (snowman-verbosity) 0)
(eprintf "Adding tuning for package ~S (~a) to local repository\n"
package version))
(let* ((cache-name (make-path (snowman-cache-directory) (basename snowball)))
(descr `(,package
,version
:tuning-only #t
:tunings (("stklos"
:url ""
:snowball ,cache-name
:md5 ,(md5sum-file snowball))))))
(copy-file snowball cache-name)
(add-description-to-local-repository! descr)))
;; ----------------------------------------------------------------------
;; build-package-description ...
;; ----------------------------------------------------------------------
......@@ -109,14 +130,4 @@
:tunings ()
:dependencies ,(build-dependencies lst))))
;; ----------------------------------------------------------------------
;; local-snowfort-add-tuning! ...
;; ----------------------------------------------------------------------
(define (local-snowfort-add-tuning! snowball package version tuning directory)
(unless (equal? tuning "stklos")
(die "Cannot manage non STklos tunings"))
(when (> (snowman-verbosity) 0)
(eprintf "Adding tuning for package ~S (~a) to local repository\n"
package version)))
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [[email protected]]
;;;; Creation date: 26-Dec-2006 18:20 (eg)
;;;; Last file update: 31-Jan-2007 14:48 (eg)
;;;; Last file update: 1-Feb-2007 17:54 (eg)
;;;;
(define interesting-tuning "stklos") ; The tuning we want to keep in our base
......@@ -274,26 +274,34 @@
(define (add-description-to-local-repository! descr)
(define (insert-descr lst name version descr)
(let Loop ((lst lst)
(res '()))
(cond
((null? lst)
(cons descr res))
((and (equal? (caar lst) name)
(equal? (cadar lst) version))
(Loop (cdr lst) res))
(else
(Loop (cdr lst) (cons (car lst) res))))))
(let* ((repo (make-path (snowman-snowforts-directory) "local"))
(old (with-input-from-file repo read))
(name (car descr))
(vers (cadr descr))
(new (insert-descr old name vers descr)))
;; save the new version
(with-output-to-file repo
(lambda ()
(pp new :port #t)))))
(let ((descr-tuning-only (key-get (cddr descr) :tuning-only #f)))
(let Loop ((lst lst)
(res '()))
(cond
((null? lst)
(cons descr res))
((and (equal? (caar lst) name)
(equal? (cadar lst) version))
(let ((lst-tuning-only (key-get (cddar lst) :tuning-only #f)))
(cond
((equal? descr-tuning-only lst-tuning-only)
;; We replace a tuning/package by another
(Loop (cdr lst) res))
(else
;; One is a package the other is a tuning
(Loop (cdr lst) (cons (car lst) res))))))
(else
(Loop (cdr lst) (cons (car lst) res)))))))
(let* ((repo (make-path (snowman-snowforts-directory) "local"))
(old (with-input-from-file repo read))
(name (car descr))
(vers (cadr descr))
(new (insert-descr old name vers descr)))
;; save the new version
(with-output-to-file repo
(lambda ()
(pp new :port #t)))))
......@@ -6,7 +6,7 @@ This is a dump of the image in file /misc/home/eg/Projects/STklos/lib/boot.img3
#include "stklos.h"
char* STk_boot_consts = "#(pair? car map apply map* cdr for-each* *expander-list* *expander-list-src* assq expander? application-expander symbol? initial-expander install-expander! expander-sources expander-sources-set! syntax-expand macro-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! 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 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 open-file &i/o-filename-error location message \"cannot open file ~S\" format backtrace %vm-backtrace filename make-condition %set-std-port! close-port dynamic-wind %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 %make-continuation %fresh-continuation? %restore-continuation %call/cc call/cc %thread-dynwind-stack set-car! set-cdr! %thread-dynwind-stack-set! procedure? \"bad procedure ~S\" call-with-values call-with-current-continuation 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 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 eval eval-from-string *%program-args* :argv argv :program-name program-name dirname file-is-directory? make-directories make-directory eq? hash-table-hash %make-hash-table make-hash-table cons hash-table-map hash-table->alist hash-table-exists? hash-table-set! for-each 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 base64-encode-string base64-decode-string base64-encode base64-decode ((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 eprintf printf fprintf \"| \" 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 string-length #\\/ char=? \"/\" \".\" string-split decompose-file-name \"^(.*)/(.+)$\" \"\\\\1\" regexp-replace string=? \"^(.*)/(.*)$\" \"\\\\2\" basename (unix cygwin-windows) memv windows #\\\\ #\\? file-separator make-path \"~A~A~A\" #\\. substring file-suffix file-prefix 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 %parameter-dynenv-push! %parameter-dynenv-pop! parameterize require-extension \"requires at least one clause\" srfi not null? ok? x 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~%\" %%require4syntax require-for-syntax %%include include autoload-file remove-autoload! autoload \"~S has not been defined in ~S\" syntax-autoload SRFI-0 (srfi0-register-feature!) (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-18 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! cond-expand \"no clause match\" \"invalid 'not' clause\" %srfi-0-expand STklos (SRFI-0) \"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 list->vector ... hyg:untag quasiquote (if begin) (set! define) letrec case unquote \"takes exactly one expression\" unquote-splicing \"invalid context within quasiquote\" append! list-tail \"%%\" 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 \"\\\\\\\\[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 STKLOS-COMPILER (eval disassemble compiler:time-display compiler:gen-line-number compiler:warn-use-undefined compiler:warn-use-undefined-postpone compiler:inline-common-functions) *compiler-port* * < <= > 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 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) (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) (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) (UNUSED-20 0) (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)) 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 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 *** \" 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\" compiler-warning 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:inline-common-functions new-label emit emit-label fetch-constant small-integer-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 verify-global compiler-show-undefined-symbols compiler-known-globals \"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-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 \"internal define-macro forbidden here ~S\" compile-define-macro compile-internal-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 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 (= < > <= >=) 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 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 %file-informations :globals \"DEBUG: create back macro ~S\\n\" :expanders compile-require \"*** Exception while evaluation of required syntax ~S\\n\" compile-require4syntax %%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 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 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 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 :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 %symbol-define 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 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 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 \"bad string ~S\" #\\% #\\~ %seconds->string date->string \"date\" current-time \"bad timeout ~S\" %thread-timeout->seconds \"thread\" current-thread %thread-end-exception-set! %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-lock! %mutex-unlock! mutex-unlock! join-timeout-exception? abandoned-mutex-exception? &thread-terminated terminated-thread-exception? :: &condition (reason) make-condition-type uncaught-exception? uncaught-exception-reason 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! \"Don't use anymore pragma, but compiler:warn-use-undef parameter\" stklos-pragma pragma define-reader-ctor REPL (main-repl repl repl-display-prompt main-repl-hook) 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 \" (near line ~a in file ~s)\" red \"**** Error~A:\\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 repl-display-prompt main-repl-hook :in G5958 :out G5959 :err G5960 \";; ~A\\n\" repl %initialize-signals green \"STklos version ~A\\t\\t[~A/~A]\\n\" machine-type %thread-system \"Copyright (C) 1999-2007 Erick Gallesio - I3S-CNRS/ESSI <[email protected]>\\n\" normal %pre-exit main-repl (REPL) compile-file \"compfile\" describe \"describe\" ((match-case . \"match\") (match-lambda . \"match\")) %print-usage \"getopt\" ((parse-arguments . \"getopt\")) ((trace . \"trace\") (untrace . \"trace\")) pp \"pp\" pretty-print null-environment \"env\" scheme-report-environment interaction-environment ((package* . \"snow-support\")) 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\" \"???\" \"**** 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 :debug \"~/.stklos/stklosrc\" \"loading file\" \"executing file\" \"evaluating\")";
char* STk_boot_consts = "#(pair? car map apply map* cdr for-each* *expander-list* *expander-list-src* assq expander? application-expander symbol? initial-expander install-expander! expander-sources expander-sources-set! syntax-expand macro-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! 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 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 open-file &i/o-filename-error location message \"cannot open file ~S\" format backtrace %vm-backtrace filename make-condition %set-std-port! close-port dynamic-wind %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 %make-continuation %fresh-continuation? %restore-continuation %call/cc call/cc %thread-dynwind-stack set-car! set-cdr! %thread-dynwind-stack-set! procedure? \"bad procedure ~S\" call-with-values call-with-current-continuation 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 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 eval eval-from-string *%program-args* :argv argv :program-name program-name dirname file-is-directory? make-directories make-directory eq? hash-table-hash %make-hash-table make-hash-table cons hash-table-map hash-table->alist hash-table-exists? hash-table-set! for-each 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 base64-encode-string base64-decode-string base64-encode base64-decode ((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 eprintf printf fprintf \"| \" 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 string-length #\\/ char=? \"/\" \".\" string-split decompose-file-name \"^(.*)/(.+)$\" \"\\\\1\" regexp-replace string=? \"^(.*)/(.*)$\" \"\\\\2\" basename (unix cygwin-windows) memv windows #\\\\ #\\? file-separator make-path \"~A~A~A\" #\\. substring file-suffix file-prefix 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 %parameter-dynenv-push! %parameter-dynenv-pop! parameterize require-extension \"requires at least one clause\" srfi not null? ok? x 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~%\" %%require4syntax require-for-syntax %%include include autoload-file remove-autoload! autoload \"~S has not been defined in ~S\" syntax-autoload SRFI-0 (srfi0-register-feature!) (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-18 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! cond-expand \"no clause match\" \"invalid 'not' clause\" %srfi-0-expand STklos (SRFI-0) \"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 list->vector ... hyg:untag quasiquote (if begin) (set! define) letrec case unquote \"takes exactly one expression\" unquote-splicing \"invalid context within quasiquote\" append! list-tail \"%%\" 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 \"\\\\\\\\[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 STKLOS-COMPILER (eval disassemble compiler:time-display compiler:gen-line-number compiler:warn-use-undefined compiler:warn-use-undefined-postpone compiler:inline-common-functions) *compiler-port* * < <= > 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 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) (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) (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) (UNUSED-20 0) (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)) 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 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 *** \" 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\" compiler-warning 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:inline-common-functions new-label emit emit-label fetch-constant small-integer-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 verify-global compiler-show-undefined-symbols compiler-known-globals \"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-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 \"internal define-macro forbidden here ~S\" compile-define-macro compile-internal-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 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 (= < > <= >=) 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 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 %file-informations :globals :expanders compile-require \"*** Exception while evaluation of required syntax ~S\\n\" compile-require4syntax %%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 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 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 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 :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 %symbol-define 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 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 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 \"bad string ~S\" #\\% #\\~ %seconds->string date->string \"date\" current-time \"bad timeout ~S\" %thread-timeout->seconds \"thread\" current-thread %thread-end-exception-set! %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-lock! %mutex-unlock! mutex-unlock! join-timeout-exception? abandoned-mutex-exception? &thread-terminated terminated-thread-exception? :: &condition (reason) make-condition-type uncaught-exception? uncaught-exception-reason 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! \"Don't use anymore pragma, but compiler:warn-use-undef parameter\" stklos-pragma pragma define-reader-ctor REPL (main-repl repl repl-display-prompt main-repl-hook) 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 \" (near line ~a in file ~s)\" red \"**** Error~A:\\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 repl-display-prompt main-repl-hook :in G5957 :out G5958 :err G5959 \";; ~A\\n\" repl %initialize-signals green \"STklos version ~A\\t\\t[~A/~A]\\n\" machine-type %thread-system \"Copyright (C) 1999-2007 Erick Gallesio - I3S-CNRS/ESSI <[email protected]>\\n\" normal %pre-exit main-repl (REPL) compile-file \"compfile\" describe \"describe\" ((match-case . \"match\") (match-lambda . \"match\")) %print-usage \"getopt\" ((parse-arguments . \"getopt\")) ((trace . \"trace\") (untrace . \"trace\")) pp \"pp\" pretty-print null-environment \"env\" scheme-report-environment interaction-environment 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\" \"???\" \"**** 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 :debug \"~/.stklos/stklosrc\" \"loading file\" \"executing file\" \"evaluating\")";
STk_instr STk_boot_code [] = {
0x23,
......@@ -236,7 +236,7 @@ STk_instr STk_boot_code [] = {
0x1f,
0xd,
0x23,
0x12,
0x17,
0x3,
0x67,
0xd,
......@@ -246,6 +246,9 @@ STk_instr STk_boot_code [] = {
0x3b,
0x13,
0x7,
0xc,
0x1d,
0x9,
0x67,
0xc,
0x3b,
......@@ -255,6 +258,8 @@ STk_instr STk_boot_code [] = {
0x13,
0x8,
0x24,
0x7,
0x24,
0x1f,
0xe,
0x23,
......@@ -17688,7 +17693,7 @@ STk_instr STk_boot_code [] = {
0xcf,
0x1,
0x21,
0x67,
0x4d,
0x6c,
0xe,
0x3,
......@@ -24908,7 +24913,7 @@ STk_instr STk_boot_code [] = {
0x1f,
0x354,
0x23,
0xae,
0xa7,
0x3,
0x25,
0x67,
......@@ -24933,7 +24938,7 @@ STk_instr STk_boot_code [] = {
0x1,
0x1,
0x1d,
0x81,
0x7a,
0x25,
0x25,
0x25,
......@@ -24969,7 +24974,7 @@ STk_instr STk_boot_code [] = {
0x0,
0x1,
0x1d,
0x59,
0x52,
0x25,
0x6a,
0x2b7,
......@@ -24986,7 +24991,7 @@ STk_instr STk_boot_code [] = {
0x2,
0x25,
0x23,
0x3b,
0x34,
0x1,
0x2a,
0x3,
......@@ -25026,13 +25031,6 @@ STk_instr STk_boot_code [] = {
0x3,
0x17,
0x25,
0x55,
0x357,
0x65,
0x56,
0x12d,
0x2,
0x25,
0x65,
0x25,
0x67,
......@@ -25049,7 +25047,7 @@ STk_instr STk_boot_code [] = {
0x6e,
0x65,
0x55,
0x358,
0x357,
0x4f,
0x56,
0xc1,
......@@ -25084,7 +25082,7 @@ STk_instr STk_boot_code [] = {
0x6,
0x24,
0x1f,
0x359,
0x358,
0x23,
0x1f,
0x3,
......@@ -25093,7 +25091,7 @@ STk_instr STk_boot_code [] = {
0x1,
0x25,
0x55,
0x35a,
0x359,
0x12,
0x102,
0x71,
......@@ -25119,7 +25117,7 @@ STk_instr STk_boot_code [] = {
0x2e,
0x24,
0x1f,
0x35b,
0x35a,
0x23,
0x20,
0x3,
......@@ -25145,17 +25143,17 @@ STk_instr STk_boot_code [] = {
0x24,
0x25,
0x55,
0x35c,
0x35b,
0x67,
0x55,
0x35d,
0x35c,
0x67,
0x6c,
0x2a0,
0x4,
0x24,
0x1f,
0x35e,
0x35d,
0x23,
0x22,
0x3,
......@@ -25183,17 +25181,17 @@ STk_instr STk_boot_code [] = {
0x24,
0x25,
0x55,
0x35f,
0x35e,
0x67,
0x55,
0x35d,
0x35c,
0x67,
0x6c,
0x2a0,
0x4,
0x24,
0x1f,
0x360,
0x35f,
0x23,
0x25,
0x3,
......@@ -25234,7 +25232,7 @@ STk_instr STk_boot_code [] = {
0x4,
0x24,
0x1f,
0x361,
0x360,
0x23,
0x24e,
0x4,
......@@ -25655,7 +25653,7 @@ STk_instr STk_boot_code [] = {
0x12,
0x100,
0x73,
0x359,
0x358,
0x3,
0x1c,
0xa6,
......@@ -25674,7 +25672,7 @@ STk_instr STk_boot_code [] = {
0x12,
0x100,
0x73,
0x35b,
0x35a,
0x3,
0x1c,
0x93,
......@@ -25699,7 +25697,7 @@ STk_instr STk_boot_code [] = {
0x80,
0x65,
0x9,
0x362,
0x361,
0x63,
0xe,
0x25,
......@@ -25712,13 +25710,13 @@ STk_instr STk_boot_code [] = {
0x12,
0x100,
0x73,
0x361,
0x360,
0x3,
0x1c,
0x6d,
0x65,
0x9,
0x35c,
0x35b,
0x63,
0xe,
0x25,
......@@ -25731,13 +25729,13 @@ STk_instr STk_boot_code [] = {
0x12,
0x100,
0x73,
0x35e,
0x35d,
0x3,
0x1c,
0x5a,
0x65,
0x9,
0x35f,
0x35e,
0x63,
0xe,
0x25,
......@@ -25750,7 +25748,7 @@ STk_instr STk_boot_code [] = {
0x12,
0x100,
0x73,
0x360,
0x35f,
0x3,
0x1c,
0x47,
......@@ -25895,7 +25893,7 @@ STk_instr STk_boot_code [] = {
0x4,
0x25,
0x55,
0x363,
0x362,
0x56,
0x2ad,
0x1,
......@@ -25966,7 +25964,7 @@ STk_instr STk_boot_code [] = {
0x1,
0x1,
0x73,
0x364,
0x363,
0x3,
0x24,
0x24,
......@@ -26006,7 +26004,7 @@ STk_instr STk_boot_code [] = {
0x0,
0x21,
0x55,
0x365,
0x364,
0x56,
0x31,
0x2,
......@@ -26034,7 +26032,7 @@ STk_instr STk_boot_code [] = {
0x1f,
0x25,
0x55,
0x366,
0x365,
0x56,
0x22,
0x1,
......@@ -26046,7 +26044,7 @@ STk_instr STk_boot_code [] = {
0x0,
0x21,
0x55,
0x367,
0x366,
0x56,
0x36,
0x2,
......@@ -26058,7 +26056,7 @@ STk_instr STk_boot_code [] = {
0x25,
0x53,
0x55,
0x366,
0x365,
0x56,
0x27,
0x2,
......@@ -26081,7 +26079,7 @@ STk_instr STk_boot_code [] = {
0x0,
0x21,
0x55,
0x368,
0x367,
0x56,
0x31,
0x2,
......@@ -26100,7 +26098,7 @@ STk_instr STk_boot_code [] = {
0x2e,
0x25,
0x55,
0x366,
0x365,
0x56,
0x1c,
0x1,
......@@ -26143,53 +26141,53 @@ STk_instr STk_boot_code [] = {
0x2b7,
0x7,
0x1f,
0x369,
0x368,
0x23,
0xa,
0x2,
0x25,
0x66,
0x55,
0x36a,
0x369,
0x65,
0x6c,
0x15,
0x3,
0x24,
0x1f,
0x36b,
0x36a,
0x23,
0xa,
0x2,
0x25,
0x66,
0x55,
0x36c,
0x36b,
0x65,
0x6c,
0x15,
0x3,
0x24,
0x1f,
0x36d,
0x36c,
0x23,
0xa,
0x2,
0x25,
0x66,
0x55,
0x36e,
0x36d,
0x65,
0x6c,
0x15,
0x3,
0x24,
0x1f,
0x36f,
0x36e,
0xa,
0xcf,
0x1f,
0x370,