452 lines
11 KiB
Common Lisp
452 lines
11 KiB
Common Lisp
|
||
; -*- 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 |