250 lines
8.2 KiB
Common Lisp
250 lines
8.2 KiB
Common Lisp
;;; Chapter 14 - Macros and Compilation
|
|
|
|
;;; Exercises
|
|
|
|
;;; Ex 14.3
|
|
;;; Write a SET-NIL macro that sets a variable to NIL.
|
|
(defmacro set-nil (var)
|
|
(list 'setq var nil))
|
|
|
|
;;; Ex 14.4
|
|
;;; Write a macro called SIMPLE-ROTATEF that switches the value of two variables.
|
|
;;; for example, if A is two and B is seven, then (SIMPLE-ROTATEF A B) shoul make A seven and B two.
|
|
;;; Obviously, setting A to B first, and then setting B to A won't work.
|
|
;;; Your macro should expand into a LET expression that holds on to the original values of the two variables and then assigns them their new values in its body.
|
|
(defmacro simple-rotatef (a b)
|
|
`(let ((clone-a ,a)
|
|
(clone-b ,b))
|
|
(setf ,a clone-b)
|
|
(setf ,b clone-a)))
|
|
|
|
;;; Ex 14.5
|
|
;;; Write a macro SET-MUTUAL that takes two variable names as input and expands into an expression that sets each variable to the name of the other.
|
|
;;; (SET-MUTUAL A B) should set A to 'B, and B to 'A.
|
|
(defmacro set-mutual (a b)
|
|
`(let ((var-a ',b)
|
|
(var-b ',a))
|
|
(setf ,a var-a)
|
|
(setf ,b var-b)))
|
|
|
|
;;; Ex 14.6
|
|
;;; Write a macro called VARIABLE-CHAIN that accepts any number of inputs.
|
|
;;; The expression (VARIABLE-CHAIN A B C D) should expand into an expression that sets A to 'B, B to 'C, and C to 'D.
|
|
(defmacro set-zero (&rest vars)
|
|
`(progn ,@(mapcar #'(lambda (var)
|
|
(list 'setf var 0))
|
|
vars)
|
|
'(zeroed ,@vars)))
|
|
|
|
(defmacro variable-chain (&rest vars)
|
|
`(progn ,@(mapcar #'(lambda (a b)
|
|
`(setf ,a ',b))
|
|
vars
|
|
(rest vars))
|
|
'(done ,@vars)))
|
|
|
|
;;; Alternative solution
|
|
(defmacro variable-chain (&rest vars)
|
|
`(progn
|
|
,@(do ((v vars (rest v))
|
|
(res nil))
|
|
((null (rest v)) (reverse res))
|
|
(push `(setf ,(first v)
|
|
',(second v))
|
|
res))))
|
|
|
|
;;; CASE STUDY: Finite State Machines
|
|
(defstruct (node (:print-function print-node))
|
|
(name nil)
|
|
(inputs nil)
|
|
(outputs nil))
|
|
|
|
(defun print-node (node stream depth)
|
|
(format stream "#<Node ~A>"
|
|
(node-name node)))
|
|
|
|
(defstruct (arc (:print-function print-arc))
|
|
(from nil)
|
|
(to nil)
|
|
(label nil)
|
|
(action nil))
|
|
|
|
(defun print-arc (arc stream depth)
|
|
(format stream "#<ARC ~A / ~A / ~A>"
|
|
(node-name (arc-from arc))
|
|
(arc-label arc)
|
|
(node-name (arc-to arc))))
|
|
|
|
(defvar *nodes*)
|
|
(defvar *arcs*)
|
|
(defvar *current-node*)
|
|
|
|
(defun initialize ()
|
|
(setf *nodes* nil)
|
|
(setf *arcs* nil)
|
|
(setf *current-node* nil))
|
|
|
|
(defmacro defnode (name)
|
|
`(add-node ', name))
|
|
|
|
(defun add-node (name)
|
|
(let ((new-node (make-node :name name)))
|
|
(setf *nodes* (nconc *nodes* (list new-node)))
|
|
new-node))
|
|
|
|
(defun find-node (name)
|
|
(or (find name *nodes* :key #'node-name)
|
|
(error "No node named ~A exists." name)))
|
|
|
|
(defmacro defarc (from label to &optional action)
|
|
`(add-arc ',from ',label ',to ',action))
|
|
|
|
(defun add-arc (from-name label to-name action)
|
|
(let* ((from (find-node from-name))
|
|
(to (find-node to-name))
|
|
(new-arc (make-arc :from from
|
|
:label label
|
|
:to to
|
|
:action action)))
|
|
(setf *arcs* (nconc *arcs* (list new-arc)))
|
|
(setf (node-outputs from)
|
|
(nconc (node-outputs from)
|
|
(list new-arc)))
|
|
(setf (node-inputs to)
|
|
(nconc (node-inputs to)
|
|
(list new-arc)))
|
|
new-arc))
|
|
|
|
(defun fsm (&optional (starting-point 'start))
|
|
(setf *current-node* (find-node starting-point))
|
|
(do ()
|
|
((null (node-outputs *current-node*)))
|
|
(one-transition)))
|
|
|
|
(defun one-transition ()
|
|
(format t "~&State ~A. Input: "
|
|
(node-name *current-node*))
|
|
(let* ((ans (read))
|
|
(arc (find ans
|
|
(node-outputs *current-node*)
|
|
:key #'arc-label)))
|
|
(unless arc
|
|
(format t "~&No arc from ~A has label ~A.~%"
|
|
(node-name *current-node*) ans)
|
|
(return-from one-transition nil))
|
|
(let ((new (arc-to arc)))
|
|
(format t "~&~A" (arc-action arc))
|
|
(setf *current-node* new))))
|
|
|
|
(defnode start)
|
|
(defnode have-5)
|
|
(defnode have-10)
|
|
(defnode have-15)
|
|
(defnode have-20)
|
|
(defnode end)
|
|
|
|
(defarc start nickel have-5 "Clunk!")
|
|
(defarc start dime have-10 "Clink!")
|
|
(defarc start coin-return start "Nothing to return!")
|
|
|
|
(defarc have-5 nickel have-10 "Clunk!")
|
|
(defarc have-5 dime have-15 "Clink!")
|
|
(defarc have-5 coin-return start "Returned five cents.")
|
|
|
|
(defarc have-10 nickel have-15 "Clunk!")
|
|
(defarc have-10 dime have-20 "Clink!")
|
|
(defarc have-10 coin-return start "Returned ten cents.")
|
|
|
|
(defarc have-15 nickel have-20 "Clunk!")
|
|
(defarc have-15 dime have-20 "Nickel change.")
|
|
(defarc have-15 gum-button end "Deliver gum.")
|
|
(defarc have-15 coin-return start "Returned fifteen cents.")
|
|
|
|
(defarc have-20 nickel have-20 "Nickel returned.")
|
|
(defarc have-20 dime have-20 "Dime returned.")
|
|
(defarc have-20 gum-button end "Deliver gum, nickel change.")
|
|
|
|
(defarc have-20 mint-button end "Deliver mints.")
|
|
(defarc have-20 coin-return start "Returned twenty cents.")
|
|
|
|
;;; Ex 14.7
|
|
;;; Extend the vending machine example to sell chocolate bars for 25 cents.
|
|
;;; Make it accept quarters as well as nickels and dimes.
|
|
;;; When you put in a quarter it should go "Ker-chunck!"
|
|
|
|
(defnode have-25)
|
|
(defnode have-30)
|
|
(defnode have-35)
|
|
(defarc start quarter have-25 "Ker-chunck!")
|
|
(defarc have-5 quarter have-30 "Ker-chunck!")
|
|
(defarc have-10 quarter have-35 "Ker-chunck!")
|
|
|
|
(defarc have-25 choc-button end "Deliver chocolate.")
|
|
(defarc have-30 choc-button end "Deliver chocolate, nickel change.")
|
|
(defarc have-35 choc-button end "Deliver chocolate, dime change.")
|
|
|
|
(defarc have-25 coin-return start "Returned twenty five cents.")
|
|
(defarc have-30 coin-return start "Returned thirty cents.")
|
|
(defarc have-35 coin-return start "Returned thirty five cents.")
|
|
|
|
;;; Ex 14.11
|
|
;;; In this keyboard exercise we will write a compiler for finite state machines that turns each node into a function.
|
|
;;; The definition of the vending machine's nodes and arcs should already be loaded into your Lisp before beginning the exercise.
|
|
|
|
;;; a.
|
|
;;; Write a function COMPILE-ARC that takes an arc as input and returns a COND clause, following the example shown previously.
|
|
;;; Test your function on some of the elements in the list *ARCS*.
|
|
;;; (COMPILE-ARC (FIRST *ARCS*)) should return this list:
|
|
((equal this-input 'nickel)
|
|
(format t "~&~A" "Clunk!")
|
|
(have-5 (rest input-syms)))
|
|
|
|
(defun compile-arc (arc)
|
|
`((equal this-input ',(arc-label arc))
|
|
(format t "~&~A" ,(arc-action arc))
|
|
(,(node-name (arc-to arc)) (rest input-syms))))
|
|
|
|
;;; b.
|
|
;;; Write a function COMPILE-NODE that takes a node as input and returns a DEFUN expression for that node.
|
|
;;; (COMPILE-NODE (FIND-NODE 'START)) should return the DEFUN shown previously.
|
|
(defun compile-node (node)
|
|
`(defun ,(node-name node) (input-syms
|
|
&aux (this-input (first input-syms)))
|
|
(cond ((null input-syms) ',(node-name node))
|
|
,@(cn-helper node)
|
|
(t (format t "No arc for ~A with label ~A."
|
|
',(node-name node) this-input)))))
|
|
|
|
(defun cn-helper (node)
|
|
(do ((result nil)
|
|
(arcs (node-outputs node) (rest arcs)))
|
|
((null arcs) result)
|
|
(setf result
|
|
(cons (compile-arc (first arcs)) result))))
|
|
|
|
;;; Book's solution
|
|
(defun compile-node (node)
|
|
(let ((name (node-name node))
|
|
(arc-clauses
|
|
(mapcar #'compile-arc
|
|
(node-outputs node))))
|
|
`(defun ,name (input-syms
|
|
&aux (this-input
|
|
(first input-syms)))
|
|
(cond ((null input-syms) ',name)
|
|
,@arc-clauses
|
|
(t (format t
|
|
"~&There is no arc from ~A with label ~S"
|
|
',name this-input))))))
|
|
;;; c.
|
|
;;; Write a macro COMPILE-MACHINE that expands into a PROGN containing a DEFUN for each node in *NODES*.
|
|
(defmacro compile-machine ()
|
|
`(progn ,@(mapcar #'compile-node *nodes*)))
|
|
|
|
;;; d.
|
|
;;; Compile the vending machine. What does the expression (START '(DIME DIME DIME GUM-BUTTO)) produce?
|
|
Clink!
|
|
Clink!
|
|
Dime returned.
|
|
Deliver gum, nickel change.
|
|
End
|