707 lines
27 KiB
Common Lisp
707 lines
27 KiB
Common Lisp
|
||
; -*- 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))
|
||
|
||
;;; --------------------------------------------------------------------
|
||
|