lac : 1f05982f72a0c9129e57d7f72650a950ad5ba11a

     1: ;;; -*-Lisp-*-
     2: 
     3: ;;; Rationale:
     4: ;;;
     5: ;;; The basic definitions, except where noted, are compatible with
     6: ;;; LISP 1.5.
     7: ;;; The evaluator itself is, though, different, and this shows in
     8: ;;; the presence of LET and the absence of FUNCTION
     9: 
    10: ;;;
    11: ;;; Definitions
    12: ;;;
    13: 
    14: (define defmacro
    15:   (macro (name binds &rest body) `(define ,name (macro ,binds ,@body))))
    16: 
    17: (defmacro defun (name binds &rest body)
    18:   `(define ,name (labels ,name , binds ,@body)))
    19: 
    20: (defmacro setq (x v) `(set ',x ,v))
    21: 
    22: (defun caar (x) (car (car x)))
    23: (defun cadr (x) (car (cdr x)))
    24: (defun cdar (x) (cdr (car x)))
    25: (defun cddr (x) (cdr (cdr x)))
    26: (defun caaar (x) (car (car (car x))))
    27: (defun caadr (x) (car (car (cdr x))))
    28: (defun cadar (x) (car (cdr (car x))))
    29: (defun caddr (x) (car (cdr (cdr x))))
    30: (defun cdaar (x) (cdr (car (car x))))
    31: (defun cdadr (x) (cdr (car (cdr x))))
    32: (defun cddar (x) (cdr (cdr (car x))))
    33: (defun cdddr (x) (cdr (cdr (cdr x))))
    34: 
    35: (defmacro let (binds &rest body)
    36:   `((lambda ,(mapcar car binds) ,@body)
    37:     ,@(mapcar cadr binds)))
    38: 
    39: ;;;
    40: ;;; Logical Connectives
    41: ;;;
    42: 
    43: (defun not (x)
    44: 	(cond (x NIL) (T)))
    45: 
    46: (defmacro or (&rest y)
    47:   (cond
    48:    (y `(cond (,(car y)) ((or ,@(cdr y)))))
    49:    (T 'NIL)))
    50: 
    51: (defmacro and (&rest y)
    52:   (cond
    53:    (y `(cond (,(car y) (and ,@(cdr y)))))
    54:    (T 'T)))
    55: 
    56: 
    57: ;;;
    58: ;;; Elementary Functions
    59: ;;;
    60: 
    61: ;; car implicit
    62: ;; cdr implicit
    63: ;; cons implicit
    64: 
    65: (defun atom (x) (cond ((consp x) NIL)(T T)))
    66: 
    67: ;; eq implicit
    68: 
    69: (defun equal (x y)
    70:   (cond
    71:    ((atom x) (cond ((atom y) (atom-equal x y))))
    72:    ((consp x)(cond ((consp y) (cond ((equal (car x) (car y))
    73: 				     (equal (cdr x) (cdr y)))))))))
    74: 
    75: (defun list (&rest y) y)
    76: 
    77: (defun null (x) (eq x NIL))
    78: 
    79: (defun listp (x) (or (null x) (consp x)))
    80: 
    81: ;; rplaca implicit
    82: ;; rplacd implicit
    83: 
    84: ;;;
    85: ;;; List Handling Functions
    86: ;;;
    87: 
    88: ;;; N.B.: LISP 1.5 seem to support only two arguments
    89: (defun append (&rest y)
    90:   (cond
    91:    ((null y)        NIL)
    92:    ((null (caar y)) (apply append (cdr y)))
    93:    (t               (cons (caar y)
    94:                           (apply append (cons (cdar y) (cdr y)))))))
    95: 
    96: (defun assoc (x a)
    97:   (cond
    98:    ((null a)           NIL)
    99:    ((equal (caar a) x) (car a))
   100:    (t                  (assoc x (cdr a)))))
   101: 
   102: (defun assq (x a)
   103:   (cond
   104:    ((null a)        NIL)
   105:    ((eq (caar a) x) (car a))
   106:    (t               (assq x (cdr a)))))
   107: 
   108: ;; differ from clisp: (nconc 'X) error here.
   109: (defun nconc (x y)
   110:   (cond ((null x) y)
   111: 	(T (let ((f (labels f (z)
   112: 			    (cond ((cdr z) (f (cdr z)))
   113: 				  (T       (rplacd z y))))))
   114: 	     (f x))
   115: 	   x)))
   116: 
   117: (defmacro conc (&rest y)
   118:   (cond
   119:    ((null y) 'NIL)
   120:    (T        `(nconc ,(car y) (conc ,@(cdr y))))))
   121: 
   122: (defun copy (x)
   123:   (cond
   124:    ((null x) NIL)
   125:    ((atom x) x)
   126:    (T        (cons (copy (car x)) (copy (cdr x))))))
   127: 
   128: (defun reverse (l)
   129:   (let ((r) (f (labels f (u v)
   130: 		  (cond (u (f (cdr u) (cons (car u) v)))
   131: 		  	(T v)))))
   132: 	  (f l NIL)))
   133: 
   134: (defun member (x l)
   135:   (cond
   136:    ((null l) NIL)
   137:    ((equal x (car l)) T)
   138:    (T        (member x (cdr l)))))
   139:     
   140: (defun member (el lst)
   141:   (if (null lst) 
   142:       NIL 
   143:       (or (eq (car lst) el) (member el (cdr lst)))))
   144: 
   145: (defun length (lst)
   146:   (cond
   147:    ((null lst) 0)
   148:    (T          (+ 1 (length (cdr lst))))))
   149: 
   150: (defun efface (x l)
   151:   (cond
   152:    ((null l)          NIL)
   153:    ((equal x (car l)) (cdr l))
   154:    (T                 (rplacd l (efface x (cdr l))))))
   155: 
   156: (defun subst (x y z)
   157: 	(cond
   158: 	 ((equal y z) 	x)
   159: 	 ((atom z)	z)	
   160: 	 (t		(cons	(subst x y (car z))
   161: 				(subst x y (cdr z))))))
   162: 
   163: ;;;
   164: ;;; Functionals
   165: ;;; N.B.: Original LISP 1.5 (not MACLISP and subsequents) had the functional
   166: ;;;       argument as last parameter.
   167: ;;;
   168: 
   169: (defun maplist (f x)
   170:   (cond
   171:    ((null x) NIL)
   172:    (T        (cons (f x) (maplist (cdr x) f)))))
   173: 
   174: (defun mapcon (f x)
   175:   (cond
   176:    ((null x) NIL)
   177:    (T        (nconc (f x) (maplist (cdr x) f)))))
   178: 
   179: (defun map (f x)
   180:   (cond
   181:    ((null x) NIL)
   182:    (T        (maplist (cdr x) f)))
   183:    NIL)
   184: 
   185: ;; mapcar is embedded, for historical reasons
   186: 
   187: (defun search (x p f u)
   188:   (cond
   189:    ((null x) (u x))
   190:    ((p x) (f x))
   191:    (t (search (cdr x) p f u))))
   192: 
   193: 
   194: ;;;
   195: ;;; Arithmetic Functions
   196: ;;; N.B.: These should work both for fixnums and floats
   197: ;;;
   198: 
   199: (defun lessp (x y) (< x y))
   200: (defun greaterp (x y) (> x y))
   201: (defun zerop (x) (eq x 0))
   202: (defun onep (x) (eq x 1))
   203: (defun minusp (x) (< x 0))
   204: (defun numberp (x) (integerp x))
   205: ;; fixp is integerp
   206: 
   207: (defun plus (&rest x)
   208:   (cond
   209:    ((null x) 0)
   210:    (t        (+ (car x) (apply plus (cdr x))))))
   211: 
   212: (defun difference (x y) (- x y))
   213: 
   214: (defun minus (x) -x)
   215: 
   216: (defun times (&rest x)
   217:   (cond
   218:    ((null x) 1)
   219:    (t        (* (car x) (apply times (cdr x))))))
   220: 
   221: (defun add1 (x) (+ x 1))
   222: 
   223: (defun sub1 (x) (- x 1))
   224: 
   225: (defun max (x &rest y)
   226:   (cond
   227:    ((null y)       x)
   228:    ((<= x (car y)) (apply max y))
   229:    (t              (apply max (cons x (cdr y))))))
   230: 
   231: (defun min (x &rest y)
   232:   (cond
   233:    ((null y)       x)
   234:    ((>= x (car y)) (apply min y))
   235:    (t              (apply min (cons x (cdr y))))))
   236: 
   237: (defun quotient (x y) (/ x y))
   238: (defun remainder (x y) (% x y))
   239: (defun divide (x y) (list (quotient x y) (remainder x y)))
   240: 
   241: (defun expt (x y)
   242:   (cond
   243:    ((zerop y) 1)
   244:    (t         (* x (expt x (sub1 y))))))
   245: 
   246: 
   247: ;;;
   248: ;;; Misc
   249: ;;; Mostly from Common Lisp
   250: ;;;
   251: 
   252: (defun first (l) (car l))
   253: (defun second (l) (first (cdr l)))
   254: (defun third (l) (second (cdr l)))
   255: (defun fourth (l) (third (cdr l)))
   256: (defun fifth (l) (fourth (cdr l)))
   257: (defun sixth (l) (fifth (cdr l)))
   258: (defun seventh (l) (sixth (cdr l)))
   259: (defun eighth (l) (seventh (cdr l)))
   260: (defun ninth (l) (eighth (cdr l)))
   261: (defun tenth (l) (ninth (cdr l)))
   262: (defun last (x) (cond ((null (cdr x)) x) (t (last (cdr x)))))
   263: 
   264: (defmacro if (test true false)
   265:   `(cond (,test ,true) (t ,false)))
   266: 
   267: (defun remove-if (test lst) 
   268:   (if (null lst) 
   269:       NIL 
   270:       (if (test (car lst)) 
   271: 	  (remove-if test (cdr lst)) 
   272: 	  (cons (car lst) (remove-if test (cdr lst)))))) 
   273: 
   274: (defun remove-if-not (test lst)
   275:   (remove-if (lambda (x) (not (test x))) lst))
   276: 
   277: (defmacro push (x place) 
   278:   (list 'set (list 'quote place) (list 'cons x place)))
   279: 
   280: (defun nthcdr (n l)
   281:        (cond ((eq n 0) l)
   282:        	     (t        (nthcdr (- n 1) (cdr l)))))
   283: (defun nth (n l)
   284:        (car (nthcdr n l)))
   285: 
   286: (defun 1+ (x) (+ 1 x))
   287: (defun 1- (x) (- x 1))
   288: (defun evenp (x) (eq (% x 2) 0))
   289: (defun oddp (x) (eq (% x 2) 1))
   290: (defmacro incf (x) `(setq ,x (1+ ,x)))
   291: (defmacro decf (x) `(setq ,x (1- ,x)))
   292: 

Generated by git2html.