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

452 lines
11 KiB
ArmAsm
Raw Permalink Normal View History

Unpack disk2.tgz
2023-05-20 05:57:05 -04:00
; -*- Mode: Lisp -*- Filename: pstd.s
;--------------------------------------------------------------------------;
; ;
; TI SCHEME -- PCS Compiler ;
; Copyright 1985 (c) Texas Instruments ;
; ;
; David Bartley ;
; ;
; Standard SCHEME Routines ;
; ;
;--------------------------------------------------------------------------;
; Modification History:
;
; tc 2/10/87 fixed implode for non-lists and lists with floats
; tc 2/10/87 BOOLEAN? and PROCEDURE? added for R^3 Report
; tc 6/01/87 seperated PSTD and PSTD2 for compiler-less system
; tc 6/09/87 made list-tail a primitive operation
(begin
(define-integrable 1+ ; 1+
(lambda (n)(+ n 1)))
(define-integrable -1+ ; -1+
(lambda (n)(- n 1)))
(define-integrable add1 ; ADD1
(lambda (n)(+ n 1)))
(define-integrable apply ; APPLY
(lambda (fn args)
(%apply fn args)))
(define-integrable caaaar (lambda (x) (caar (caar x)))) ; CAXXXR
(define-integrable caaadr (lambda (x) (caar (cadr x))))
(define-integrable caadar (lambda (x) (caar (cdar x))))
(define-integrable caaddr (lambda (x) (caar (cddr x))))
(define-integrable cadaar (lambda (x) (cadr (caar x))))
(define-integrable cadadr (lambda (x) (cadr (cadr x))))
(define-integrable caddar (lambda (x) (cadr (cdar x))))
;(define-integrable cadddr (lambda (x) (cadr (cddr x))))
(define-integrable call/cc ; CALL/CC
(lambda (exp)
(%call/cc exp)))
(define-integrable call-with-current-continuation ; CALL-w-c-c
(lambda (exp)
(%call/cc exp)))
(define-integrable cdaaar (lambda (x) (cdar (caar x)))) ; CDXXXR
(define-integrable cdaadr (lambda (x) (cdar (cadr x))))
(define-integrable cdadar (lambda (x) (cdar (cdar x))))
(define-integrable cdaddr (lambda (x) (cdar (cddr x))))
(define-integrable cddaar (lambda (x) (cddr (caar x))))
(define-integrable cddadr (lambda (x) (cddr (cadr x))))
(define-integrable cdddar (lambda (x) (cddr (cdar x))))
(define-integrable cddddr (lambda (x) (cddr (cddr x))))
(define-integrable empty-stream? ; EMPTY-STREAM?
(lambda (x)
(eq? x the-empty-stream)))
(define-integrable modulo ; MODULO
(lambda (p q)
(let ((rem (remainder p q)))
(if (negative? (* p q))
(if (zero? rem)
rem
(+ rem q))
rem))))
(define-integrable null? ; NULL?
(lambda (obj)
(not obj)))
(define-integrable reverse ; REVERSE
(lambda (L)
(reverse! (%append L '()))))
(define-integrable sub1 ; SUB1
(lambda (n)(- n 1)))
(define-integrable procedure? ; PROCEDURE?
(lambda (obj)
(proc? obj)))
); end begin
(begin
(define ascii->symbol ; ASCII->SYMBOL
(lambda (n)
(string->symbol (make-string 1 (integer->char n)))))
(define (copy x) ; COPY
(if (atom? x)
x
(cons (copy (car x))
(copy (cdr x)))))
(define %delay ; %DELAY
(lambda (state)
(lambda ()
(when (closure? state) ; not yet memoized?
(set! state (list (state))))
(car state))))
(define delayed-object? ; DELAYED-OBJECT?
(lambda (obj)
(and (vector? obj)
(positive? (vector-length obj))
(eq? (vector-ref obj 0) '#!DELAYED-OBJECT))))
(define (delete! obj lst) ; DELETE!
(letrec ((loop (lambda (obj a b z)
(cond ((atom? b)
z)
((equal? obj (car b))
(set-cdr! a (cdr b))
(loop obj a (cdr b) z))
(else
(loop obj b (cdr b) z))))))
(cond ((atom? lst)
'())
((equal? obj (car lst))
(delete! obj (cdr lst)))
(else
(loop obj lst (cdr lst) lst)))))
(define (delq! obj lst) ; DELQ!
(letrec ((loop (lambda (obj a b z)
(cond ((atom? b)
z)
((eq? obj (car b))
(set-cdr! a (cdr b))
(loop obj a (cdr b) z))
(else
(loop obj b (cdr b) z))))))
(cond ((atom? lst)
'())
((eq? obj (car lst))
(delq! obj (cdr lst)))
(else
(loop obj lst (cdr lst) lst)))))
(define %execute ; %EXECUTE
(lambda (compiled-object)
(%%execute compiled-object))) ; dangerous primitive!
(define exit ; EXIT
(lambda ()
(transcript-off)
(%halt)
(reset)))
(define explode ; EXPLODE
(lambda (obj)
(let ((x (if (symbol? obj)
(symbol->string obj)
obj)))
(cond ((string? x)
(do ((x x x)
(index 0
(add1 index))
(end (string-length x)
end)
(result '()
(cons (string->symbol
(substring x index (+ index 1)))
result)))
((= index end)
(reverse! result))))
((integer? x)
(do ((n (abs x)
(quotient n 10))
(result '()
(cons (ascii->symbol (+ (remainder n 10) 48))
result)))
((< n 10)
(let ((result (cons (ascii->symbol (+ n 48)) result)))
(if (negative? x) (cons '- result) result)))))
(else x)))))
(define for-each ; FOR-EACH
(lambda (f l)
(do ((f f f)
(l l (cdr l)))
((atom? l))
(f (car l)))))
(define force ; FORCE
(lambda (obj)
(if (and (vector? obj)
(positive? (vector-length obj))
(eq? (vector-ref obj 0) '#!DELAYED-OBJECT))
((vector-ref obj 1))
(%error-invalid-operand 'FORCE obj))))
(define gc ; GC
(lambda args
;; do NOT define with define DEFINE-INTEGRABLE !!
;; do NOT hoist the call to %CLEAR-REGISTERS
(cond ((or (null? args)
(null? (car args)))
(%clear-registers) ; unbind the VM registers
(%garbage-collect)) ; invoke the GC operation
(else
(%clear-registers) ; unbind the VM registers
(%compact-memory))))) ; GC and compaction both
(define gcd ; GCD
(lambda args
(letrec ((gcd*
(lambda (args result)
(if (null? args)
result
(gcd* (cdr args)
(gcd2 (abs (car args)) result)))))
(gcd2
(lambda (p q)
(if (zero? q)
p
(gcd2 q (remainder p q))))))
(gcd* args 0))))
(define gensym ; GENSYM
(letrec
((counter->string
(lambda (c n)
(cond ((positive? c)
(let ((string (counter->string (quotient c 10)(+ n 1))))
(string-set! string
(- (string-length string) n 1)
(string-ref "0123456789" (remainder c 10)))
string))
((zero? n)
"0")
(else
(make-string n '()))))))
(let ((string "G")
(counter -1))
(lambda args
(set! counter (+ counter 1))
(when (not (null? args))
(let ((arg (car args)))
(cond ((integer? arg)
(set! counter (abs arg)))
((string? arg)
(set! string arg))
((symbol? arg)
(set! string (symbol->string arg)))
(else '()))))
(string->uninterned-symbol
(string-append string
(counter->string counter 0)))))))
(define head ; HEAD
(lambda (stream)
(if (and (vector? stream)
(positive? (vector-length stream))
(eq? (vector-ref stream 0) '#!STREAM))
(vector-ref stream 1)
(%error-invalid-operand 'HEAD stream))))
(define implode ; IMPLODE
(lambda (L)
(cond ((null? L) '||)
((atom? L)
(%error-invalid-operand 'implode L))
(else
(let ((n (length L)))
(do ((L L
(cdr L))
(string (make-string n '())
string)
(index 0
(add1 index)))
((null? L)
(string->symbol string))
(let* ((x (car L)))
(string-set!
string
index
(cond ((symbol? x)
(string-ref (symbol->string x) 0))
((string? x)
(string-ref x 0))
((char? x)
x)
((integer? x)
(integer->char x))
(else
(error "Invalid list element fot IMPLODE" x)) )))))))))
(define lcm ; LCM
(letrec ((lcm*
(lambda (args result)
(if (null? args)
result
(let ((a (car args)))
(if (zero? a)
0
(lcm* (cdr args)
(quotient (abs (* a result))
(gcd a result)))))))))
(lambda args
(lcm* args 1))))
(define (list->stream L) ; LIST->STREAM
(if (null? L)
the-empty-stream
(let ((heapL L)) ; control heap allocation of L
(cons-stream (car L)
(list->stream (cdr heapL))))))
(define list->vector ; LIST->VECTOR
(lambda (L)
(let ((n (length L)))
(do ((v (make-vector n) v)
(i 0 (1+ i))
(L L (cdr L)))
((null? L) v)
(vector-set! v i (car L))))))
(define list-ref ; LIST-REF
(lambda (x n)
(car (list-tail x n))))
;;;
;;; List-tail was re-defined as a primitive on 6-9-87
;;;
;;;(define (list-tail x n) ; LIST-TAIL
;;; (if (positive? n)
;;; (list-tail (cdr x)(sub1 n))
;;; x))
(define map ; MAP
(lambda (f l)
(do ((f f f)
(l l (cdr l))
(acc '() (cons (f (car l)) acc)))
((atom? l)
(reverse! acc)))))
(define mapc ; MAPC
for-each)
(define mapcar ; MAPCAR
map)
(define random ; RANDOM
(letrec ((loop
(lambda (r m+ m)
(if (> r m+) ; enough precision?
(remainder r m)
(loop (+ (* r 8192)(%random)) m+ m)))))
(lambda (m)
(let ((r (%random))) ; 14 bits
(if (and (< m 10241) (< r (- 16383 (remainder 16383 m)))) ;10 bits scaled by 10, plus 1
(remainder r m)
(loop r (* m 1024) m))))))
(define (randomize seed) ; RANDOMIZE
(let ((|2^32-1| (sub1 (* 65536 65536))))
(if (and (<= (minus |2^32-1|) seed)
(<= seed |2^32-1|))
(%esc2 20 seed) ;seed with the given number
(%esc2 20 0)))) ;seed derived from time of day
(define runtime ; RUNTIME
(lambda ()
(let* ((t1 (%internal-time))
(hours (car t1))
(minutes (cadr t1))
(seconds (caddr t1))
(hundreds (cadddr t1)))
(+ (* 100 (+ (* 60 (+ (* 60 hours)
minutes))
seconds))
hundreds))))
(define stream? ; STREAM?
(lambda (obj)
(or (eq? obj the-empty-stream)
(and (vector? obj)
(positive? (vector-length obj))
(eq? (vector-ref obj 0) '#!STREAM)))))
(define (stream->list stream) ; STREAM->LIST
(if (empty-stream? stream)
'()
(cons (head stream)
(stream->list (tail stream)))))
(define symbol->ascii ; SYMBOL->ASCII
(lambda (s)
(char->integer (string-ref (symbol->string s) 0))))
(define tail ; TAIL
(lambda (stream)
(if (and (vector? stream)
(positive? (vector-length stream))
(eq? (vector-ref stream 0) '#!STREAM))
((vector-ref stream 2))
(%error-invalid-operand 'TAIL stream))))
(define thaw ; THAW
(lambda (thunk)
(thunk)))
(define vector->list ; VECTOR->LIST
(lambda (v)
(do ((n (vector-length v) n)
(i 0 (1+ i))
(L '() (cons (vector-ref v i) L)))
((>= i n)
(reverse! L)))))
(define boolean? ; BOOLEAN?
(lambda (obj)
(or (eq? obj #T) (null? obj) #F)))
); end begin