/usr/share/maxima/5.32.1/src/letmac.lisp is in maxima-src 5.32.1-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 | ;;; -*- Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The data in this file contains enhancments. ;;;;;
;;; ;;;;;
;;; Copyright (c) 1984,1987 by William Schelter,University of Texas ;;;;;
;;; All rights reserved ;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(in-package :maxima)
;; Destructuring DEFUN must be added to this at some point.
(defvar *let-macro-vals* nil)
;; Kludge to avoid warning that a different file is redefining
;; LET and LET*. SI has LET and LET* externed, so there is no
;; "illegally defining" warning.
(defmacro destructuring-let (pairs &body body)
(do ((pairs pairs (cdr pairs))
(vars nil)
(*let-macro-vals* nil)
(tem))
((null pairs)
(cond ((not (null vars))
`(cl:let ,(nreverse (loop for v in vars
for w in *let-macro-vals*
collect (list v w)))
,@body))
((null (cdr body))
(car body))
(t `(progn . ,body))))
(cond ((atom (car pairs))
(or (symbolp (car pairs))
(error "Garbage found in `let' pattern: ~S" (car pairs)))
(setq vars (cons (car pairs) vars))
(setq *let-macro-vals* (cons nil *let-macro-vals*)))
(t
(setq tem vars)
(setq vars (let-macro-get-vars (caar pairs) vars))
(or (eq tem vars)
(setq body (nconc (let-macro-hair (caar pairs)
(cadar pairs)
*let-macro-vals*)
body)))))))
(defun let-macro-get-vars (pattern vars)
(cond ((null pattern) vars)
((atom pattern)
(or (symbolp pattern)
(error "Garbage found in `let' pattern: ~S" pattern))
(setq *let-macro-vals* (cons nil *let-macro-vals*))
(cons pattern vars))
(t (let-macro-get-vars (cdr pattern)
(let-macro-get-vars (car pattern) vars)))))
(defmacro desetq (&rest p)
(do ((p p (cddr p))
(body nil)
(tem))
((null p)
`(progn . ,body))
(cond ((atom (cdr p))
(error "Odd number of args to `desetq': ~S" p))
((atom (car p))
(or (symbolp (car p))
(error "Garbage found in `desetq' pattern: ~S" (car p)))
(and (null (car p))
(error "Bad `desetq' pattern: ~S" (car p)))
(setq body (nconc body `((setq ,(car p) ,(cadr p))))))
(t
(setq tem (cons nil nil))
(setq body (nconc body
`((setq ,(let-macro-get-last-var (car p))
. ,tem)
. ,(let-macro-hair (car p) (cadr p) tem))))))))
(defun let-macro-get-last-var (pattern)
(cond ((atom pattern) pattern)
(t
(or (let-macro-get-last-var (cdr pattern))
(let-macro-get-last-var (car pattern))))))
(defun let-macro-hair (pattern code cell)
(cond ((null pattern) nil)
((atom pattern)
(rplaca cell code)
nil)
(t
(let ((avar (let-macro-get-last-var (car pattern)))
(dvar (let-macro-get-last-var (cdr pattern))))
(cond ((null avar)
(if (null dvar)
nil
(let-macro-hair (cdr pattern) `(cdr ,code) cell)))
((null dvar)
(let-macro-hair (car pattern) `(car ,code) cell))
(t
(rplaca cell code)
(let ((acell (cons nil nil))
(dcell (cons nil nil)))
(cons `(setq ,avar . ,acell)
(nconc (let-macro-hair (car pattern) `(car ,dvar) acell)
(cons `(setq ,dvar . ,dcell)
(let-macro-hair (cdr pattern) `(cdr ,dvar) dcell)))))))))))
(defmacro destructuring-let* (pairs &body body)
(cond ((loop for v in pairs
always (or (symbolp v) (and (consp v) (symbolp (car v)))))
`(cl:let* ,pairs ,@body))
(t
(do ((a (reverse pairs) (cdr a))
(b body `((destructuring-let (,(car a)) . ,b))))
((null a)
(cond ((null (cdr b)) (car b))
(t `(progn . ,b))))))))
|