Page Numbers: Yes X: 310 Y: 10.44" First Page: 1
Margins: Top: 1.0" Bottom: 1.3"
Heading:

CS-370 (FALL 1982)2-LISP GENERAL UTILITIES

————————————————————————————————————————————

2-LISP GENERAL UTILITIES

————————————————————————————————————————————

;;; -*- October 6, 1982 2:19 AM -*-

;;; Vector Predicates and Selector Functions:
;;; -----------------------------------------

(define 1ST (lambda expr [x] (nth 1 x)))
(define 2ND (lambda expr [x] (nth 2 x)))
(define 3RD (lambda expr [x] (nth 3 x)))
(define 4TH (lambda expr [x] (nth 4 x)))
(define 5TH (lambda expr [x] (nth 5 x)))
(define 6TH (lambda expr [x] (nth 6 x)))

(define REST (lambda expr [x] (tail 1 x)))
(define FOOT (lambda expr [x] (tail (length x) x)))

(define EMPTY (lambda expr [x] (= (length x) 0)))
(define UNIT (lambda expr [x] (= (length x) 1)))
(define DOUBLE (lambda expr [x] (= (length x) 2)))

;;; Type Predicates:
;;; ----------------

(define ATOM (lambda expr [x] (= (type x) ’atom)))
(define RAIL (lambda expr [x] (= (type x) ’rail)))
(define PAIR (lambda expr [x] (= (type x) ’pair)))
(define NUMERAL (lambda expr [x] (= (type x) ’numeral)))
(define HANDLE (lambda expr [x] (= (type x) ’handle)))
(define BOOLEAN (lambda expr [x] (= (type x) ’boolean)))
(define CHARAT (lambda expr [x] (= (type x) ’charat)))
(define CLOSURE (lambda expr [x] (= (type x) ’closure)))

(define NUMBER (lambda expr [x] (= (type x) ’number)))
(define SEQUENCE (lambda expr [x] (= (type x) ’sequence)))
(define TRUTH-VALUE (lambda expr [x] (= (type x) ’truth-value)))
(define CHARACTER (lambda expr [x] (= (type x) ’character)))
(define FUNCTION (lambda expr [x] (= (type x) ’function)))

(define VECTOR
(lambda expr [x] (member (type x) [’rail ’sequence])))

(define EXTERNAL
(lambda expr [x]
(member (type x) [’number ’sequence ’truth-value ’character ’function])))

(define INTERNAL
(lambda expr [x]
(member (type x)
[’atom ’rail ’pair ’numeral ’handle ’boolean ’charat ’closure])))

;;; MEMBER:
;;; -------

(define MEMBER
(lambda expr [element vector]
(cond [(empty vector) $F]
[(= element (1st vector)) $T]
[$T (member element (rest vector))])))

;;; Two Generalized Constructors:
;;; -----------------------------

(define VCONS
(lambda expr [template]
(if (rail template) (rcons) (scons))))

(define XCONS
(lambda expr args
(pcons (1st args) (rcons . (rest args)))))

;;; Four Standard REPLACING Functions:
;;; -----------------------------------

(define RPLACT
(lambda expr [n rail new-tail]
(replace (tail n rail) new-tail)))

(define RPLACN
(lambda expr [n rail new-element]
(replace (tail (- n 1) rail) (prep new-element (tail n rail)))))

(define RPLACA
(lambda expr [pair new-car]
(replace pair (pcons new-car (cdr pair)))))

(define RPLACD
(lambda expr [pair new-cdr]
(replace pair (pcons (car pair) new-cdr))))

;;; MAP:
;;; ----

(define MAP
(lambda expr args
(cond [(empty (2nd args)) (vcons (2nd args))]
[(double args)
(prep ((1st args) (1st (2nd args)))
(map (1st args) (rest (2nd args))))]
[$T (prep ((1st args) . (map 1st (rest args)))
(map . (prep (1st args) (map rest (rest args)))))])))

;;; Vector Utilities:
;;; -----------------

(define COPY
(lambda expr [vector]
(if (empty vector)
(vcons vector)
(prep (1st vector) (copy (rest vector))))))

(define CONCATENATE
(lambda expr [rail1 rail2]
(replace (foot rail1) rail2)))

(define APPEND
(lambda expr [vector1 vector2]
(if (empty vector1)
vector2
(prep (1st vector1)
(append (rest vector1) vector2)))))

;;; COND, BLOCK:
;;; ------------

(define COND
(lambda macro clauses
̀ (if ,(1st (1st clauses))
(block . ,(rest (1st clauses))
(cond . ,(rest clauses)))))

(define BLOCK
(lambda macro clauses
(if (unit clauses)
(1st clauses)
̀ ((lambda expr ? (block . ,(rest clauses)))
,(1st clauses)))))

;;; BOOLEANS:
;;; ---------

(define NOT (lambda expr [x] (if x $F $T)))

(define AND
(lambda macro clauses
(if (rail clauses)
(if (empty clauses)
’$T
̀ (if ,(1st clauses)
(and . ,(rest clauses))
$F))
̀ ↑(reduce ’and (normalise ,↑clauses)))))

(define OR
(lambda macro clauses
(if (rail clauses)
(if (empty clauses)
’$F
̀ (if ,(1st clauses)
$T
(or . ,(rest clauses))))
̀ ↑(reduce ’or (normalise ,↑clauses)))))

;;; LET and LET*
;;; ------------

(define LET
(lambda macro args
̀ ((lambda expr ,(map 1st (1st args)) (block . ,(rest args)))
. ,(map 2nd (1st args)))))

(define LET*
(lambda macro args
(if (empty (1st args))
̀ (block . ,(rest args))
̀ (let [,(1st (1st args))]
(let* . ,(prep (rest (1st args)) (rest args)))))))

;;; SELECT and SELECTQ:
;;; -------------------

Needs to be re-written! The current defintion of SELECTQ works, but is ugly in that it introduces a visible identifier into the context in which clauses will be processed (this is not necessary). Also, SELECT needs to be defined.

(define SELECTQ
(lambda macro [list body]
̀ (let [[select-key ,(1st args)]]
,(select-@ (rest args)))))

(define SELECTQ-@
(lambda expr [cases]
(cond [(empty cases) (rcons)]
[(= (1st (1st cases)) ’$T) ̀ (block . ,(rest (1st cases)))]
[$T ̀ (if (,(if (atom (1st (1st cases))) ↑= ↑member)
select-key
,↑(1st (1st cases)))
(block . ,(rest (1st cases)))
,(select-@ (rest cases)))])))

;;; READ and PRINT:
;;; ---------------

Yet to be defined.

;;; PUSH and POP
;;; ------------

(define PUSH
(lambda expr [element stack]
(replace ↑stack
↑(prep element
(if (empty stack) (scons) (rest stack))))
stack))

(define POP
(lambda expr [stack]
(let [[top (1st stack)]]
(replace ↑stack ↑(rest stack))
top)))))