⟦243440de5⟧

TextFile

;;; -*- Scheme -*- Revised Revised Report on Scheme definitions

;; Set up macros so that they will be available if "cross-syntaxed" 
;; (compile-time) and if loaded (run-time).

(declare (usual-integrations))

(let-syntax ()

(define-syntax define-macro
  (macro (pattern . body)
    (let ((the-macro `(macro ,(cdr pattern) ,@body)))
      `(sequence
	(define-syntax ,(car pattern) ,the-macro)	; Compile-time
	(add-syntax! ',(car pattern) ,the-macro)))))	; Run-time

(define-syntax primitive
  (macro (exp)
    (if (and (pair? exp) (eq? (car exp) 'QUOTE))
	(make-primitive-procedure (cadr exp))
	`(make-primitive-procedure ,exp))))

;;;; Special forms

(define-macro (and . exps)
  `(conjunction ,@exps))

(define-macro (or . exps)
  `(disjunction ,@exps))

(define-macro (case expr . clauses)
  (let ((need-temp? (not (symbol? expr))))
    (let ((the-expression (if need-temp? (generate-uninterned-symbol) expr)))
      (define (transform-clause original single multi)
	(define (process-selector exp)
	  `(,single ,the-expression ',exp))
	(let ((selector (car original)))
	  (cons
	   ;; This is done like this only for speed.
	   (cond ((null? (cdr selector))
		  (process-selector (car selector)))
		 ((< (length selector) 4)
		  `(or ,@(mapcar process-selector selector)))
		 (else `(,multi ,the-expression ',selector)))
	   (cdr original))))
      (define (check-selector selector)
	(or (null? selector)
	    (and (not (number? (car selector)))
		 (not (string? (car selector)))
		 (check-selector (cdr selector)))))
      (define (process-clause clause)
	(cond ((not (pair? clause))
	       (error "Case: Bad clause" clause))
	      ((not (pair? (car clause)))
	       (if (eq? (car clause) 'ELSE)
		   clause
		   (error "Case: Bad clause" clause)))
	      ((check-selector (car clause))
	       (transform-clause clause 'eq? 'memq))
	      (else (transform-clause clause 'eqv? 'memv))))
      (if need-temp?
	  `(let ((,the-expression ,expr))
	     (cond ,@(mapcar process-clause clauses)))
	  `(cond ,@(mapcar process-clause clauses))))))

(define-macro (let* bindings . body)
  (define (do-one bindings)
    (if (null? bindings)
	`(sequence ,@body)
	`(let (,(car bindings)) ,(do-one (cdr bindings)))))
  (do-one bindings))

(define-macro (letrec bindings . body)
  `(let ,(mapcar (lambda (pair) (list (car pair)))
                 bindings)
      ,@(mapcar (lambda (pair) `(set! ,(car pair) ,(cadr pair)))
                bindings)
      ,@body))

(define-macro (rec var exp)
  `(letrec ((,var ,exp)) ,var))

(define-macro (begin . exps)
  `(sequence ,@exps))

(define-macro (do bindings test . body)
  (let ((the-name (generate-uninterned-symbol)))
    `((named-lambda (,the-name ,@(mapcar car bindings))
	(cond ,test
	      (else ,@body
		    (,the-name
		     ,@(mapcar (lambda (binding)
				 (if (or (null? (cdr binding))
					 (null? (cddr binding)))
				     (car binding)
				     (caddr binding)))
			       bindings)))))
      ,@(mapcar (lambda (binding)
		  (if (null? (cdr binding))
		      `',(make-unassigned-object)
		      (cadr binding)))
		bindings))))
\f


;;;; Procedures

;;; Symbols

(define symbol->string symbol-print-name)

(define string->symbol
  (let ((prim (make-primitive-procedure 'intern-character-list)))
    (named-lambda (string->symbol string)
      (prim (string->list string)))))
   
;;; Miscellaneous control primitives

;; Ugh, bletch!!.  This is to fool the cross-syntaxer since apply is one 
;; of the usual integrations and the cross-syntaxer will therefore not allow
;; assignment even if it the variable is not used.

(lexical-assignment
 (the-environment)
 'apply
 (named-lambda (apply f . all)
   ((primitive 'apply) f ((primitive 'apply) cons* all))))

(define map mapcar)
(define for-each mapc)
(define call-with-current-continuation catch)
\f


;;;; Numbers

;; *** Exactness input syntax is not recognized.
;; Exact numbers are not implemented.  Everything is inexact.
;; Complex numbers and rationals are not implemented.  Only integers
;; and floats (reals) are provided.

(define complex? number?)
(define real? number?)
(define rational? number?)

(define (exact? x) #!FALSE)
(define (inexact? x) #!TRUE)

(define =? =)
(define <? <)
(define >? >)
(define <=? <=)
(define >=? >=)

(define (modulo x y)
  (let ((res (remainder x y)))
    (cond ((negative? x)
	   (if (negative? y)
	       res
	       (+ y res)))
	  ((negative? y) (+ y res))
	  (else res))))

(define lcm)

(let ((original-gcd gcd))
  (define (pairwise-gcd x y)
    (cond ((zero? x) y)
	  ((zero? y) x)
	  (else (original-gcd x y))))
	
  (define (pairwise-lcm x y)
    (if (or (zero? x) (zero? y))
	0
	(/ (abs (* x y)) (original-gcd x y))))	  

  (define ((lexperize what identity) . all)
    (let loop ((current identity) (left all))
	 (if (null? left)
	     current
	     (loop (what current (car left))
		   (cdr left)))))

  (set! gcd (lexperize pairwise-gcd 0))
  (set! lcm (lexperize pairwise-lcm 1)))

(define (rationalize x #!optional y) x)

(define acos)
(define asin)

(let ((pi (* 4 ((primitive '&atan) 1)))
      (pi/2 (* 2 ((primitive '&atan) 1))))
  (set! acos
	(named-lambda (acos x)
	  (if (zero? x)
	      pi/2
	      (let ((sq (* x x)))
		(cond ((> sq 1) (error "Acos: argument out of range" x))
		      ((positive? x)
		       ((primitive '&atan) (/ (sqrt (- 1 sq)) x)))
		      (else (- pi ((primitive '&atan) (/ (sqrt (- 1 sq))
							 (- x))))))))))

  (set! asin
	(named-lambda (asin x)
	  (let ((sq (* x x)))
	    (cond ((= sq 1) (if (positive? x) pi/2 (- pi/2)))
		  ((> sq 1) (error "Asin: argument out of range" x))
		  ((positive? x)
		   ((primitive '&atan) (/ x (sqrt (- 1 sq)))))
		  (else (- ((primitive '&atan) (/ (- x)
						  (sqrt (- 1 sq)))))))))))

(define (exact->inexact x) x)
(define (inexact->exact x)
  (error "Inexact->exact: exact numbers not supported" x))

;; *** Formats unimplemented.

(define (number->string number format)
  (if (not (equal? format '(HEUR)))
      (error "Number->string: Unimplemented format" format))
  (prin1-to-string number))

;; *** Exactness ignored, radices do not quite work right

(define (string->number string exactness radix)
  (let ((place (assq radix '((B . #b10) (O . #o10) (D . #d10) (X . #x10)))))
    (if (null? place)
	(error "String->number: Bad radix" radix)
	(fluid-let ((*parser-radix* (cdr place)))
	  (with-input-from-string string read)))))
\f


;;;; Characters

;; #\ syntax is not recognized except for a few characters.
;; All are used below.  Use #/ for printing characters instead.

(define *MIN-CHAR* 0)
(define *MAX-CHAR* 127)

(define (char? x)
  (conjunction (integer? x) (<= *MIN-CHAR* x *MAX-CHAR*)))

(define char=? =)
(define char<? <)
(define char>? >)
(define char<=? <=)
(define char>=? >=)

(define ((ci base-pred) c1 c2)
  (base-pred (char-upcase c1) (char-upcase c2)))

(define char-ci=? (ci char=?))
(define char-ci<? (ci char<?))
(define char-ci>? (ci char>?))
(define char-ci<=? (ci char<=?))
(define char-ci>=? (ci char>=?))

(define (char-upper-case? c)
  (and (char-alphabetic? c) (char=? c (char-upcase c))))

(define (char-lower-case? c)
  (and (char-alphabetic? c) (char=? c (char-downcase c))))

(define (char-alphabetic? c)
  (if (memq (char-upcase c)
	    '(#/A #/B #/C #/D #/E #/F #/G #/H #/I
	      #/J #/K #/L #/M #/N #/O #/P #/Q #/R
	      #/S #/T #/U #/V #/W #/X #/Y #/Z))
      #!TRUE
      #!FALSE))

(define (char-numeric? c)
  (if (memq c '(#/0 #/1 #/2 #/3 #/4 #/5 #/6 #/7 #/8 #/9))
      #!TRUE
      #!FALSE))

(define (char-whitespace? c)
  (if (memq c '(#\TAB #\LF #\FF #\CR #\SP))
      #!TRUE
      #!FALSE))

(define char->integer identity-procedure)
(define integer->char identity-procedure)

;; *** These procedures assume ascii

(define (char-upcase x)
  (if (<= #/a x #/z)
      (+ x (- #/A #/a))
      x))

(define (char-downcase x)
  (if (<= #/A x #/Z)
      (+ x (- #/a #/A))
      x))
\f


;;;; Strings

(define (string-null? string)
  (zero? (string-size string)))

(define string=? string-equal?)
(define string<? string-less?)
(define (string>? x y) (string-less? y x))

(define (string-compare pred s1 s2)
  (let ((one (string-length s1)) (two (string-length s2)))
    (let loop ((index (-1+ (min one two))))
      (cond ((not (negative? index))
	     (and (pred (string-ref s1 index) (string-ref s2 index))
		  (loop (-1+ index))))
	    ((= one two) #!TRUE)
	    ((> one two) 'LONG)
	    (else 'SHORT)))))

(define (string-ci=? s1 s2)
  (and (= (string-length s1) (string-length s2))
       (string-compare char-ci=? s1 s2)))

(define ((string-comparison pred good-case) s1 s2)
  (let ((res (string-compare pred s1 s2)))
    (if (symbol? res)
	(eq? res good-case)
	res)))

(define string<=? (string-comparison char<=? 'SHORT))
(define string>=? (string-comparison char>=? 'LONG))
(define string-ci<=? (string-comparison char-ci<=? 'SHORT))
(define string-ci>=? (string-comparison char-ci>=? 'LONG))

(define (string-ci<? s1 s2)
  (and (string-ci<=? s1 s2)
       (not (and (= (string-length s1) (string-length s2))
		 (string-ci=? s1 s2)))))

(define (string-ci>? s1 s2)
  (string-ci<? s2 s1))

(define (make-string n #!optional char)
  (make-filled-string n (if (unassigned? char) #\null char)))

(define string-length string-size)

(define (string-fill! string char)
  (substring-fill! string 0 (string-size string) char))

(define (substring-fill! string start end char)
  (define (loop n)
    (if (= n end)
	'DONE
	(sequence (string-set! string n char)
	          (loop (1+ n)))))
  (loop start))

;; Missing SUBSTRING-MOVE-RIGHT! SUBSTRING-MOVE-LEFT!

\f


;;;; Vectors

(define vector-length vector-size)

(define (make-vector size #!optional fill)
  (vector-cons size (if (unassigned? fill) '() fill)))

(define (vector-fill! vec fill)
  (define (loop m)
    (if (< m 0)
        'DONE
	(sequence (vector-set! vec m fill)
                  (loop (-1+ m)))))
  (loop (-1+ (vector-size vec))))
\f


;;;; I/O

(define input-port? input-stream?)
(define output-port? output-stream?)
(define current-input-port current-input-stream)
(define current-output-port current-output-stream)
(define open-input-file open-input-stream)
(define open-output-file open-output-stream)
(define close-input-port close-input-stream)
(define close-output-port close-output-stream)

(define (call-with-input-file string proc)
  (let ((port (open-input-file string)))
    (let ((val (proc port)))
      (close-input-port port)
      val)))

(define (call-with-output-file string proc)
  (let ((port (open-output-file string)))
    (let ((val (proc port)))
      (close-output-port port)
      val)))

(define read-char)
(define eof-object?)

(let ((the-eof-object (cons '*THE-EOF-OBJECT* '())))
  (set! eof-object?
    (named-lambda (eof-object? obj)
      (eq? obj the-eof-object)))

  ;; Compatible with old since new is not defined when a second
  ;; argument is given.

  (define (make-rrrs-reader old-read)
    (lambda (#!optional port eof-object)
      (cond ((unassigned? port)
	     (old-read (current-input-port) the-eof-object))
	    ((unassigned? eof-object)
	     (old-read port the-eof-object))
	    (else (old-read port eof-object)))))

  (set! read (make-rrrs-reader read))
  (set! read-char (make-rrrs-reader tyi))

  (set! read-file
	(named-lambda (read-file filename)
	  (with-input-from-file filename
	    (lambda ()
	      (define (readloop object)
		(if (eof-object? object)
		    '()
		    (cons object (readloop (read)))))
	      (readloop (read))))))
  )

;; Missing CHAR-READY?

(define write prin1)
(define display princ)
(define write-char tyo)

;; The old print Lisp function

(define (write-line obj #!optional port)
  (if (unassigned? port)
      (set! port (current-output-port)))
  (newline port)
  (write obj port)
  (write-char #\SP port))

(define transcript-on photo)
(define transcript-off tofu)

) ;; End of let-syntax.
DataMuseum.dk

DKUUG/EUUG Conference tapes

⟦243440de5⟧ TextFile

Derivation

TextFile
