/[cmucl]/src/compiler/macros.lisp
ViewVC logotype

Diff of /src/compiler/macros.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.39 by wlott, Tue Aug 24 02:12:18 1993 UTC revision 1.40 by ram, Wed Aug 25 00:16:09 1993 UTC
# Line 27  Line 27 
27    
28  (proclaim '(special *wild-type* *universal-type* *compiler-error-context*))  (proclaim '(special *wild-type* *universal-type* *compiler-error-context*))
29    
30    (declaim (ftype function (setf dylan::value-datum) dylan::find-module
31                    dylan::lookup-varinfo-value
32                    dylan::parse-and-convert dylan::value-datum))
33    
34  ;;;; Deftypes:  ;;;; Deftypes:
35    
36  ;;;  ;;;
# Line 1106  Line 1110 
1110                 (setf (event-info-count v) 0))                 (setf (event-info-count v) 0))
1111             *event-info*)             *event-info*)
1112    (values))    (values))
1113    
1114    
1115    ;;;; Generic list (?) functions:
1116    
1117    (proclaim '(inline find-in position-in map-in))
1118    
1119    ;;; Find-In  --  Interface
1120    ;;;
1121    (defun find-in (next element list &key (key #'identity)
1122                         (test #'eql test-p) (test-not nil not-p))
1123      "Find Element in a null-terminated List linked by the accessor function
1124      Next.  Key, Test and Test-Not are the same as for generic sequence
1125      functions."
1126      (when (and test-p not-p)
1127        (error "Silly to supply both :Test and :Test-Not."))
1128      (if not-p
1129          (do ((current list (funcall next current)))
1130              ((null current) nil)
1131            (unless (funcall test-not (funcall key current) element)
1132              (return current)))
1133          (do ((current list (funcall next current)))
1134              ((null current) nil)
1135            (when (funcall test (funcall key current) element)
1136              (return current)))))
1137    
1138    ;;; Position-In  --  Interface
1139    ;;;
1140    (defun position-in (next element list &key (key #'identity)
1141                         (test #'eql test-p) (test-not nil not-p))
1142      "Return the position of Element (or NIL if absent) in a null-terminated List
1143      linked by the accessor function Next.  Key, Test and Test-Not are the same as
1144      for generic sequence functions."
1145      (when (and test-p not-p)
1146        (error "Silly to supply both :Test and :Test-Not."))
1147      (if not-p
1148          (do ((current list (funcall next current))
1149               (i 0 (1+ i)))
1150              ((null current) nil)
1151            (unless (funcall test-not (funcall key current) element)
1152              (return i)))
1153          (do ((current list (funcall next current))
1154               (i 0 (1+ i)))
1155              ((null current) nil)
1156            (when (funcall test (funcall key current) element)
1157              (return i)))))
1158    
1159    
1160    ;;; Map-In  --  Interface
1161    ;;;
1162    (defun map-in (next function list)
1163      "Map Function over the elements in a null-terminated List linked by the
1164      accessor function Next, returning a list of the results."
1165      (collect ((res))
1166        (do ((current list (funcall next current)))
1167            ((null current))
1168          (res (funcall function current)))
1169        (res)))
1170    
1171    
1172    ;;; Deletef-In  --  Interface
1173    ;;;
1174    (defmacro deletef-in (next place item &environment env)
1175      "Deletef-In Next Place Item
1176      Delete Item from a null-terminated list linked by the accessor function Next
1177      that is stored in Place.  Item must appear exactly once in the list."
1178      (multiple-value-bind
1179          (temps vals stores store access)
1180          (get-setf-method place env)
1181        (let ((n-item (gensym))
1182              (n-place (gensym))
1183              (n-current (gensym))
1184              (n-prev (gensym)))
1185          `(let* (,@(mapcar #'list temps vals)
1186                  (,n-place ,access)
1187                  (,n-item ,item))
1188             (if (eq ,n-place ,n-item)
1189                 (let ((,(first stores) (,next ,n-place)))
1190                   ,store)
1191                 (do ((,n-prev ,n-place ,n-current)
1192                      (,n-current (,next ,n-place)
1193                                  (,next ,n-current)))
1194                     ((eq ,n-current ,n-item)
1195                      (setf (,next ,n-prev)
1196                            (,next ,n-current)))))
1197             (undefined-value)))))
1198    
1199    
1200    ;;; Push-In  --  Interface
1201    ;;;
1202    (defmacro push-in (next item place &environment env)
1203      "Push Item onto a list linked by the accessor function Next that is stored in
1204      Place."
1205      (multiple-value-bind
1206          (temps vals stores store access)
1207          (get-setf-method place env)
1208        `(let (,@(mapcar #'list temps vals)
1209               (,(first stores) ,item))
1210           (setf (,next ,(first stores)) ,access)
1211           ,store
1212           (undefined-value))))
1213    
1214    
1215    ;;; EPOSITION  --  Interface
1216    ;;;
1217    (defmacro eposition (&rest args)
1218      `(or (position ,@args)
1219           (error "Shouldn't happen?")))

Legend:
Removed from v.1.39  
changed lines
  Added in v.1.40

  ViewVC Help
Powered by ViewVC 1.1.5