conservatory
/
pcs
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
pcs/newpcs/popcodes.s

707 lines
27 KiB
ArmAsm
Raw Normal View History

Unpack disk2.tgz
2023-05-20 05:57:05 -04:00
; -*- Mode: Lisp -*- Filename: popcodes.s
;--------------------------------------------------------------------------;
; ;
; TI SCHEME -- PCS Compiler ;
; Copyright 1985, 1987 (c) Texas Instruments ;
; ;
; David Bartley ;
; ;
; Primitive Functions and Opcodes ;
; ;
; tc 2/10/87 READ-STRING opcode added ;
; rb 3/20/87 %XESC opcode added ;
; rb 4/ 1/87 pcs-primop-+, -* modified; no error was being signalled ;
; for a single non-numeric argument to either + or * since ;
; pcs-primop-std-n2 assumes a unary arg is the operator's ;
; identity element and removes the operator; so, the ;
; arg was never type-checked since the operator's handler ;
; never got called; now force unarys to binarys to keep ;
; the operator ;
; tc 4/13/87 make-string primop handler changed to handle optional ;
; 2nd argument ;
; ;
;--------------------------------------------------------------------------;
(define pcs-define-primop
(lambda (op handler)
(putprop op handler 'pcs*primop-handler)))
(define (pcs-primop-std-n2 form) ; n-ary to binary, left associative
(if (atom? form)
`(%%get-global%% (quote ,form)) ; funarg use
(begin
(pcs-chk-length>= form form 2)
(cond ((null? (cddr form)) ; unary?
(cadr form)) ; --> identity
((null? (cdddr form))
form) ; binary
(else
(let ((op (car form))
(a (cadr form))
(b (caddr form))
(rest (cdddr form)))
(pcs-primop-std-n2
`(,op (,op ,a ,b) . ,rest))))))))
(define (pcs-primop-append* form) ; for append, append!, string-append
(if (atom? form)
`(%%get-global%% (quote ,form)) ; funarg use
(let ((op (car form)))
(pcs-chk-length>= form form 1)
(cond ((null? (cdr form)) ; no args?
(if (eq? op 'STRING-APPEND)
''""
''()))
((null? (cddr form)) ; one arg?
(if (eq? op 'STRING-APPEND)
`(STRING-APPEND ,(cadr form) '"")
(cadr form)))
((null? (cdddr form)) ; two args?
(case op
((APPEND) `(%APPEND . ,(cdr form)))
((APPEND!) form)
(else
`(let ((%00000 ,(cadr form))
(%00001 ,(caddr form)))
(%STRING-APPEND %00000 0 (STRING-LENGTH %00000)
'()
%00001 0 (STRING-LENGTH %00001))))))
((and (null? (cddddr form))
(eq? op 'STRING-APPEND)) ; 3 args
`(let ((%00000 ,(cadr form))
(%00001 ,(caddr form))
(%00002 ,(cadddr form)))
(%STRING-APPEND %00000 0 (STRING-LENGTH %00000)
%00001
%00002 0 (STRING-LENGTH %00002))))
(else
(let ((a (cadr form))
(b (caddr form))
(rest (cdddr form)))
(pcs-primop-append*
`(,op ,a (,op ,b . ,rest)))))))))
(define pcs-primop-+ ; "+" handler
(lambda (form)
(if (and (not (atom? form))
(null? (cdr form)))
0
(if (and (not (atom? form))
(null? (cddr form)))
`(+ 0 ,(cadr form))
(pcs-primop-std-n2 form)))))
(define pcs-primop-- ; "-" handler
(lambda (form)
(cond ((and (not (atom? form))
(not (atom? (cdr form)))
(null? (cddr form)))
`(minus ,(cadr form)))
(t (pcs-primop-std-n2 form)))))
(define pcs-primop-* ; "*" handler
(lambda (form)
(if (and (not (atom? form))
(null? (cdr form)))
1
(if (and (not (atom? form))
(null? (cddr form)))
`(* 1 ,(cadr form))
(pcs-primop-std-n2 form)))))
(define pcs-primop-/ ; "/" handler
(lambda (form)
(cond ((and (not (atom? form))
(not (atom? (cdr form)))
(null? (cddr form)))
`(/ '1 ,(cadr form)))
(t (pcs-primop-std-n2 form)))))
(define (pcs-primop-vector form) ; "vector" handler
(cond ((atom? form)
`(%%get-global%% (quote vector)))
(else
`(list->vector (list . ,(cdr form))))))
(define (pcs-primop-list form) ; "list" handler
(cond ((atom? form)
`(%%get-global%% (quote list)))
((atom? (cdr form)) ; (list)
''())
((atom? (cddr form)) ; (list a)
form)
((atom? (cdddr form))
(cons '%list2 (cdr form)))
(else
(let ((rest (pcs-primop-list (cons 'list (cddr form)))))
`(cons ,(cadr form) ,rest)))))
(define (pcs-primop-list* form) ; "list*" handler
(cond ((atom? form)
`(%%get-global%% (quote list*)))
((atom? (cdr form)) ; (list*)
''())
((atom? (cddr form)) ; (list* a)
(cadr form))
(else
(let ((rest (pcs-primop-list* (cons 'list* (cddr form)))))
`(cons ,(cadr form) ,rest)))))
(define pcs-primop-make-vector ; "make-vector" handler
(lambda (form)
(cond ((atom? form)
`(%%get-global%% (quote ,form))) ; funarg use
((and (not (atom? (cdr form))) ; unary?
(null? (cddr form)))
form)
((and (not (atom? (cdr form))) ; binary?
(not (atom? (cddr form)))
(null? (cdddr form)))
`(let ((%00000 (make-vector ,(cadr form))))
(begin (vector-fill! %00000 ,(caddr form))
%00000)))
(else
(pcs-chk-length= form form 3)))))
(define pcs-primop-io-1 ; optional PORT arg
(lambda (form)
(cond ((atom? form)
`(%%get-global%% (quote ,form))) ; funarg use
((null? (cdr form))
`(,(car form) '())) ; add null port
((and (not (atom? (cdr form)))
(null? (cddr form)))
form) ; PORT supplied
(else
(pcs-chk-length= form form 2)))))
;
; Note that make-string uses the following primop definition to take
; care of its optional second argument.
;
(define pcs-primop-io-2 ; optional 2nd PORT arg
(lambda (form)
(cond ((atom? form)
`(%%get-global%% (quote ,form))) ; funarg use
((and (not (atom? (cdr form)))
(null? (cddr form))) ; add null port
`(,(car form) ,(cadr form) '()))
((and (not (atom? (cdr form)))
(not (atom? (cddr form)))
(null? (cdddr form)))
form) ; PORT supplied
(else
(pcs-chk-length= form form 3)))))
;;; --------------------------------------------------------------------
;;; !! NOTE !!
;;; Each primitive operation defined with PCS-DEFINE-PRIMOP must also
;;; be represented at runtime as a closure object in case the name is
;;; used as a "funarg." The error handler can auto-create such
;;; closures when both PCS*PRIMOP-HANDLER and PCS*OPCODE properties are
;;; integers. Others must have such closures defined explicitly. Many
;;; of them are defined in the PCS source file PFUNARG.S.
;;; --------------------------------------------------------------------
(begin
(pcs-define-primop '%%bind-fluid%% 2)
(pcs-define-primop '%%car 1)
(pcs-define-primop '%%cdr 1)
(pcs-define-primop '%%def-global%% 2)
(pcs-define-primop '%%execute 1)
(pcs-define-primop '%%fasl 1)
(pcs-define-primop '%%fluid-bound?%% 1)
(pcs-define-primop '%%get-fluid%% 1)
(pcs-define-primop '%%get-global%% 1)
(pcs-define-primop '%%get-scoops%% 1)
(pcs-define-primop '%%set-fluid%% 2)
(pcs-define-primop '%%set-global%% 2)
(pcs-define-primop '%%set-scoops%% 2)
(pcs-define-primop '%%unbind-fluid%% 1)
(pcs-define-primop '%append 2)
(pcs-define-primop '%apply 2)
(pcs-define-primop '%begin-debug 0)
(pcs-define-primop '%call/cc 1)
(pcs-define-primop '%car 1)
(pcs-define-primop '%cdr 1)
(pcs-define-primop '%clear-registers 0)
(pcs-define-primop '%clear-window 1)
(pcs-define-primop '%close-port 1)
(pcs-define-primop '%compact-memory 0)
(pcs-define-primop '%define 3)
(pcs-define-primop '%env-lu 2)
(pcs-define-primop '%esc1 1)
(pcs-define-primop '%esc2 2)
(pcs-define-primop '%esc3 3)
(pcs-define-primop '%esc4 4)
(pcs-define-primop '%esc5 5)
(pcs-define-primop '%esc6 6)
(pcs-define-primop '%esc7 7)
(pcs-define-primop '%xesc (lambda (form) form))
(pcs-define-primop '%garbage-collect 0)
(pcs-define-primop '%graphics 7)
(pcs-define-primop '%halt 0)
(pcs-define-primop '%internal-time 0)
(pcs-define-primop '%list2 2)
(pcs-define-primop '%logxor 2)
(pcs-define-primop '%logand 2)
(pcs-define-primop '%logior 2)
(pcs-define-primop '%make-window 1)
(pcs-define-primop '%open-port 2)
(pcs-define-primop '%random 0)
(pcs-define-primop '%reify 2)
(pcs-define-primop '%reify! 3)
(pcs-define-primop '%reify-port 2)
(pcs-define-primop '%reify-port! 3)
(pcs-define-primop '%reify-stack 1)
(pcs-define-primop '%reify-stack! 2)
(pcs-define-primop '%restore-window 2)
(pcs-define-primop '%save-window 1)
(pcs-define-primop '%set-global-environment 1)
(pcs-define-primop '%sfpos 3) ; set-file-position!
(pcs-define-primop '%start-timer 1)
(pcs-define-primop '%stop-timer 0)
(pcs-define-primop '%string-append 7)
(pcs-define-primop '%substring-display 5)
(pcs-define-primop '%transcript 1)
)
(begin
(pcs-define-primop '* pcs-primop-*)
(pcs-define-primop '+ pcs-primop-+)
(pcs-define-primop '- pcs-primop--)
(pcs-define-primop '/ pcs-primop-/ )
(pcs-define-primop '< 2)
(pcs-define-primop '<= 2)
(pcs-define-primop '<=? 2)
(pcs-define-primop '<> 2)
(pcs-define-primop '<>? 2)
(pcs-define-primop '<? 2)
(pcs-define-primop '= 2)
(pcs-define-primop '=? 2)
(pcs-define-primop '> 2)
(pcs-define-primop '>= 2)
(pcs-define-primop '>=? 2)
(pcs-define-primop '>? 2)
(pcs-define-primop 'abs 1)
(pcs-define-primop 'append pcs-primop-append*)
(pcs-define-primop 'append! pcs-primop-append*)
(pcs-define-primop 'assoc 2)
(pcs-define-primop 'assq 2)
(pcs-define-primop 'assv 2)
(pcs-define-primop 'atom? 1)
(pcs-define-primop 'caaar 1)
(pcs-define-primop 'caadr 1)
(pcs-define-primop 'caar 1)
(pcs-define-primop 'cadar 1)
(pcs-define-primop 'cadddr 1)
(pcs-define-primop 'caddr 1)
(pcs-define-primop 'cadr 1)
(pcs-define-primop 'car 1)
(pcs-define-primop 'cdaar 1)
(pcs-define-primop 'cdadr 1)
(pcs-define-primop 'cdar 1)
(pcs-define-primop 'cddar 1)
(pcs-define-primop 'cdddr 1)
(pcs-define-primop 'cddr 1)
(pcs-define-primop 'cdr 1)
(pcs-define-primop 'ceiling 1)
(pcs-define-primop 'char->integer 1)
(pcs-define-primop 'char-ci<? 2)
(pcs-define-primop 'char-ci=? 2)
(pcs-define-primop 'char-downcase 1)
(pcs-define-primop 'char-ready? pcs-primop-io-1)
(pcs-define-primop 'char-upcase 1)
(pcs-define-primop 'char<? 2)
(pcs-define-primop 'char=? 2)
(pcs-define-primop 'char? 1)
(pcs-define-primop 'closure? 1)
(pcs-define-primop 'complex? 1)
(pcs-define-primop 'cons 2)
(pcs-define-primop 'continuation? 1)
(pcs-define-primop 'display pcs-primop-io-2)
(pcs-define-primop 'environment-parent 1)
(pcs-define-primop 'environment? 1)
(pcs-define-primop 'eq? 2)
(pcs-define-primop 'equal? 2)
(pcs-define-primop 'eqv? 2)
(pcs-define-primop 'even? 1)
(pcs-define-primop 'float 1)
(pcs-define-primop 'float? 1)
(pcs-define-primop 'floor 1)
(pcs-define-primop 'getprop 2)
(pcs-define-primop 'integer->char 1)
(pcs-define-primop 'integer? 1)
(pcs-define-primop 'last-pair 1)
(pcs-define-primop 'length 1)
(pcs-define-primop 'list pcs-primop-list)
(pcs-define-primop 'list* pcs-primop-list*)
(pcs-define-primop 'list-tail 2)
(pcs-define-primop 'make-packed-vector 3)
(pcs-define-primop 'make-string pcs-primop-io-2) ; handle optional 2nd arg
(pcs-define-primop 'make-vector pcs-primop-make-vector)
(pcs-define-primop 'max pcs-primop-std-n2)
(pcs-define-primop 'member 2)
(pcs-define-primop 'memq 2)
(pcs-define-primop 'memv 2)
(pcs-define-primop 'min pcs-primop-std-n2)
(pcs-define-primop 'minus 1)
(pcs-define-primop 'negative? 1)
(pcs-define-primop 'newline pcs-primop-io-1)
(pcs-define-primop 'not 1)
(pcs-define-primop 'number? 1)
(pcs-define-primop 'object-hash 1)
(pcs-define-primop 'object-unhash 1)
(pcs-define-primop 'odd? 1)
(pcs-define-primop 'pair? 1)
(pcs-define-primop 'port? 1)
(pcs-define-primop 'positive? 1)
(pcs-define-primop 'prin1 pcs-primop-io-2)
(pcs-define-primop 'princ pcs-primop-io-2)
(pcs-define-primop 'print pcs-primop-io-2)
(pcs-define-primop 'print-length 1)
(pcs-define-primop 'proc? 1)
(pcs-define-primop 'proplist 1)
(pcs-define-primop 'putprop 3)
(pcs-define-primop 'quotient 2)
(pcs-define-primop 'rational? 1)
(pcs-define-primop 'read-line pcs-primop-io-1)
(pcs-define-primop 'read-atom pcs-primop-io-1)
(pcs-define-primop 'read-char pcs-primop-io-1)
(pcs-define-primop 'real? 1)
(pcs-define-primop 'remainder 2)
(pcs-define-primop 'remprop 2)
(pcs-define-primop 'reset 0)
(pcs-define-primop 'reverse! 1)
(pcs-define-primop 'round 1)
(pcs-define-primop 'scheme-reset 0)
(pcs-define-primop 'set-car! 2)
(pcs-define-primop 'set-cdr! 2)
(pcs-define-primop 'string->symbol 1)
(pcs-define-primop 'string->uninterned-symbol 1)
(pcs-define-primop 'string-append pcs-primop-append*)
(pcs-define-primop 'string-fill! 2)
(pcs-define-primop 'string-length 1)
(pcs-define-primop 'string-ref 2)
(pcs-define-primop 'string-set! 3)
(pcs-define-primop 'string? 1)
(pcs-define-primop 'substring 3)
(pcs-define-primop 'substring-find-next-char-in-set 4)
(pcs-define-primop 'substring-find-previous-char-in-set 4)
(pcs-define-primop 'symbol->string 1)
(pcs-define-primop 'symbol? 1)
(pcs-define-primop 'the-environment 0)
(pcs-define-primop '%make-hashed-environment 0)
(pcs-define-primop 'truncate 1)
(pcs-define-primop 'vector pcs-primop-vector)
(pcs-define-primop 'vector-fill! 2)
(pcs-define-primop 'vector-length 1)
(pcs-define-primop 'vector-ref 2)
(pcs-define-primop 'vector-set! 3)
(pcs-define-primop 'vector? 1)
(pcs-define-primop 'window-save-contents 1)
(pcs-define-primop 'window-restore-contents 2)
(pcs-define-primop 'write pcs-primop-io-2)
(pcs-define-primop 'write-char pcs-primop-io-2)
(pcs-define-primop 'zero? 1)
)
;;; --------------------------------------------------------------------
(define pcs-define-opcode ; !! NOTE !!
(lambda (op opcode) ; negative values mark
(putprop op opcode 'pcs*opcode))) ; side-effecting operations
;;; -- opcode assignments --
(begin
(pcs-define-opcode '%%car 064) ; (%%car nil) => nil
(pcs-define-opcode '%%cdr 065) ; (%%cdr nil) => nil
(pcs-define-opcode '%%fasl -191)
(pcs-define-opcode '%*imm 084)
(pcs-define-opcode '%+imm 081)
(pcs-define-opcode '%/imm 086)
(pcs-define-opcode '%append 113)
(pcs-define-opcode '%apply -056)
(pcs-define-opcode '%call/cc -054)
(pcs-define-opcode '%car 089) ; (%car nil) => #!unbound
(pcs-define-opcode '%cdr 090) ; (%cdr nil) => #!unbound
(pcs-define-opcode '%clear-window -211)
(pcs-define-opcode '%close-port -177)
(pcs-define-opcode '%define -220)
(pcs-define-opcode '%env-lu 219)
(pcs-define-opcode '%esc1 -232)
(pcs-define-opcode '%esc2 -233)
(pcs-define-opcode '%esc3 -234)
(pcs-define-opcode '%esc4 -235)
(pcs-define-opcode '%esc5 -236)
(pcs-define-opcode '%esc6 -237)
(pcs-define-opcode '%esc7 -238)
(pcs-define-opcode '%xesc -239)
(pcs-define-opcode '%graphics -215)
(pcs-define-opcode '%halt -248)
(pcs-define-opcode '%list2 120)
(pcs-define-opcode '%logxor 125)
(pcs-define-opcode '%logand 126)
(pcs-define-opcode '%logior 127)
(pcs-define-opcode '%make-window -208)
(pcs-define-opcode '%open-port -176)
(pcs-define-opcode '%random -091)
(pcs-define-opcode '%reify 216)
(pcs-define-opcode '%reify! -226)
(pcs-define-opcode '%reify-port 210)
(pcs-define-opcode '%reify-port! -209)
(pcs-define-opcode '%reify-stack 229)
(pcs-define-opcode '%reify-stack! -230)
(pcs-define-opcode '%restore-window -213)
(pcs-define-opcode '%save-window -212)
(pcs-define-opcode '%set-global-environment -225)
(pcs-define-opcode '%sfpos -231) ; set-file-position!
(pcs-define-opcode '%start-timer -174)
(pcs-define-opcode '%stop-timer -175)
(pcs-define-opcode '%string-append 214)
(pcs-define-opcode '%substring-display -172)
(pcs-define-opcode '%transcript -189)
)
(begin
(pcs-define-opcode '* 083)
(pcs-define-opcode '+ 080)
(pcs-define-opcode '- 082)
(pcs-define-opcode '/ 085)
(pcs-define-opcode '< 092)
(pcs-define-opcode '<= 093)
(pcs-define-opcode '<=? 093)
(pcs-define-opcode '<> 097)
(pcs-define-opcode '<>? 097)
(pcs-define-opcode '<? 092)
(pcs-define-opcode '= 094)
(pcs-define-opcode '=? 094)
(pcs-define-opcode '> 095)
(pcs-define-opcode '>= 096)
(pcs-define-opcode '>=? 096)
(pcs-define-opcode '>? 095)
(pcs-define-opcode 'abs 149)
(pcs-define-opcode 'append! -112)
(pcs-define-opcode 'assoc 110)
(pcs-define-opcode 'assq 108)
(pcs-define-opcode 'assv 109)
(pcs-define-opcode 'atom? 128)
(pcs-define-opcode 'caaar 070)
(pcs-define-opcode 'caadr 071)
(pcs-define-opcode 'caar 066)
(pcs-define-opcode 'cadar 072)
(pcs-define-opcode 'cadddr 078)
(pcs-define-opcode 'caddr 073)
(pcs-define-opcode 'cadr 067)
(pcs-define-opcode 'car 064) ; same as %%car
(pcs-define-opcode 'cdaar 074)
(pcs-define-opcode 'cdadr 075)
(pcs-define-opcode 'cdar 068)
(pcs-define-opcode 'cddar 076)
(pcs-define-opcode 'cdddr 077)
(pcs-define-opcode 'cddr 069)
(pcs-define-opcode 'cdr 065) ; same as %%cdr
(pcs-define-opcode 'ceiling 153)
(pcs-define-opcode 'char->integer 161)
(pcs-define-opcode 'char-ci<? 195)
(pcs-define-opcode 'char-ci=? 193)
(pcs-define-opcode 'char-downcase 197)
(pcs-define-opcode 'char-ready? 190)
(pcs-define-opcode 'char-upcase 196)
(pcs-define-opcode 'char<? 194)
(pcs-define-opcode 'char=? 192)
(pcs-define-opcode 'char? 156)
(pcs-define-opcode 'closure? 129)
(pcs-define-opcode 'complex? 137) ; same as NUMBER?
(pcs-define-opcode 'cons 079)
(pcs-define-opcode 'continuation? 131)
(pcs-define-opcode 'display -179)
(pcs-define-opcode 'environment-parent 218)
(pcs-define-opcode 'environment? 157)
(pcs-define-opcode 'eq? 100)
(pcs-define-opcode 'equal? 102)
(pcs-define-opcode 'eqv? 101)
(pcs-define-opcode 'even? 132)
(pcs-define-opcode 'float 150)
(pcs-define-opcode 'float? 133)
(pcs-define-opcode 'floor 152)
(pcs-define-opcode 'getprop 116)
(pcs-define-opcode 'integer->char 160)
(pcs-define-opcode 'integer? 135)
(pcs-define-opcode 'last-pair 166)
(pcs-define-opcode 'length 165)
(pcs-define-opcode 'list 111)
(pcs-define-opcode 'list-tail 122)
(pcs-define-opcode 'make-packed-vector 171)
(pcs-define-opcode 'make-string 201)
(pcs-define-opcode 'make-vector 168)
(pcs-define-opcode 'max 098)
(pcs-define-opcode 'member 105)
(pcs-define-opcode 'memq 103)
(pcs-define-opcode 'memv 104)
(pcs-define-opcode 'min 099)
(pcs-define-opcode 'minus 151)
(pcs-define-opcode 'negative? 147)
(pcs-define-opcode 'newline -181)
(pcs-define-opcode 'not 136)
(pcs-define-opcode 'number? 137)
(pcs-define-opcode 'object-hash -227)
(pcs-define-opcode 'object-unhash 228)
(pcs-define-opcode 'odd? 138)
(pcs-define-opcode 'pair? 139)
(pcs-define-opcode 'port? 140)
(pcs-define-opcode 'positive? 148)
(pcs-define-opcode 'prin1 -178)
(pcs-define-opcode 'princ -179)
(pcs-define-opcode 'print -180)
(pcs-define-opcode 'print-length 184)
(pcs-define-opcode 'proc? 141)
(pcs-define-opcode 'proplist 118)
(pcs-define-opcode 'putprop -117)
(pcs-define-opcode 'quotient 087)
(pcs-define-opcode 'rational? 135) ; same as INTEGER?
(pcs-define-opcode 'read-line -186)
(pcs-define-opcode 'read-atom -187)
(pcs-define-opcode 'read-char -188)
(pcs-define-opcode 'real? 137) ; same as NUMBER?
(pcs-define-opcode 'remainder 088)
(pcs-define-opcode 'remprop -119)
(pcs-define-opcode 'reset -251)
(pcs-define-opcode 'reverse! -106)
(pcs-define-opcode 'round 155)
(pcs-define-opcode 'scheme-reset -252)
(pcs-define-opcode 'set-car! -020)
(pcs-define-opcode 'set-cdr! -021)
(pcs-define-opcode 'string->symbol 203)
(pcs-define-opcode 'string->uninterned-symbol 204)
(pcs-define-opcode 'string-fill! -202)
(pcs-define-opcode 'string-length 198)
(pcs-define-opcode 'string-ref 199)
(pcs-define-opcode 'string-set! -200)
(pcs-define-opcode 'string? 143)
(pcs-define-opcode 'substring 167)
(pcs-define-opcode 'substring-find-next-char-in-set 206)
(pcs-define-opcode 'substring-find-previous-char-in-set 207)
(pcs-define-opcode 'symbol->string 205)
(pcs-define-opcode 'symbol? 144)
(pcs-define-opcode 'the-environment 217)
(pcs-define-opcode '%make-hashed-environment 62)
(pcs-define-opcode 'truncate 154)
(pcs-define-opcode 'vector-fill! -170)
(pcs-define-opcode 'vector-length 169)
(pcs-define-opcode 'vector-ref 011)
(pcs-define-opcode 'vector-set! -019)
(pcs-define-opcode 'vector? 145)
(pcs-define-opcode 'window-save-contents -212)
(pcs-define-opcode 'window-restore-contents -213)
(pcs-define-opcode 'write -178)
(pcs-define-opcode 'write-char -179)
(pcs-define-opcode 'zero? 146)
)
;;; --------------------------------------------------------------------
(begin
(pcs-define-opcode 'LOAD 000)
(pcs-define-opcode 'LOAD-CONSTANT 001)
(pcs-define-opcode 'LOAD-IMMEDIATE 002)
(pcs-define-opcode 'LOAD-LOCAL 004)
(pcs-define-opcode 'LOAD-LEX 005)
(pcs-define-opcode 'LOAD-ENV 006)
(pcs-define-opcode 'LOAD-GLOBAL 007)
(pcs-define-opcode 'LOAD-FLUID 008)
(pcs-define-opcode 'STORE-LOCAL -012)
(pcs-define-opcode 'STORE-LEX -013)
(pcs-define-opcode 'STORE-ENV -014)
(pcs-define-opcode 'STORE-GLOBAL -015)
(pcs-define-opcode 'STORE-GLOBAL-DEF -031)
(pcs-define-opcode 'STORE-FLUID -016)
(pcs-define-opcode 'POP -024)
(pcs-define-opcode 'PUSH -025)
(pcs-define-opcode 'DROP -026)
(pcs-define-opcode 'DROP-ENV -061)
(pcs-define-opcode 'PUSH-ENV -221)
(pcs-define-opcode 'BIND-FLUID -029)
(pcs-define-opcode 'UNBIND-FLUIDS -030)
(pcs-define-opcode '%%fluid-bound?%% 134)
(pcs-define-opcode 'J_S -032)
(pcs-define-opcode 'JN_S -034)
(pcs-define-opcode 'JNN_S -036)
(pcs-define-opcode 'JA_S -038)
(pcs-define-opcode 'JNA_S -040)
(pcs-define-opcode 'JE_S -042)
(pcs-define-opcode 'JNE_S -044)
(pcs-define-opcode 'J_L -033)
(pcs-define-opcode 'JN_L -035)
(pcs-define-opcode 'JNN_L -037)
(pcs-define-opcode 'JA_L -039)
(pcs-define-opcode 'JNA_L -041)
(pcs-define-opcode 'JE_L -043)
(pcs-define-opcode 'JNE_L -045)
(pcs-define-opcode 'CALL -048)
(pcs-define-opcode 'CALL-TR -049)
(pcs-define-opcode 'CCC -050)
(pcs-define-opcode 'CCC-TR -051)
(pcs-define-opcode 'CALL-CLOSURE -052)
(pcs-define-opcode 'CALL-CLOSURE-TR -053)
(pcs-define-opcode 'CCC-CLOSED -054)
(pcs-define-opcode 'CCC-CLOSED-TR -055)
(pcs-define-opcode 'APPLY-CLOSURE -056)
(pcs-define-opcode 'APPLY-CLOSURE-TR -057)
(pcs-define-opcode 'EXIT -059)
(pcs-define-opcode 'CLOSE -060)
(pcs-define-opcode '%begin-debug -255)
(pcs-define-opcode '%clear-registers -253)
(pcs-define-opcode '%compact-memory -247)
(pcs-define-opcode '%%execute -058)
(pcs-define-opcode '%garbage-collect -249)
(pcs-define-opcode '%internal-time 250)
)
;;; --------------------------------------------------------------------
(begin
(putprop '%begin-debug #!true 'pcs*nilargop) ; no source or dest
(putprop '%clear-registers #!true 'pcs*nilargop) ; no source or dest
(putprop '%compact-memory #!true 'pcs*nilargop) ; no source or dest
(putprop '%garbage-collect #!true 'pcs*nilargop) ; no source or dest
(putprop '%halt #!true 'pcs*nilargop) ; no source or dest
(putprop 'reset #!true 'pcs*nilargop) ; no source or dest
(putprop 'scheme-reset #!true 'pcs*nilargop) ; no source or dest
)
;;; --------------------------------------------------------------------
(begin ; collect garbage
(%clear-registers)
(%compact-memory))
;;; --------------------------------------------------------------------