(DEFINE-FILE-INFO §READTABLE "XCL" §PACKAGE "INTERLISP")

(filecreated "24-Oct-86 20:14:25" {eris}<lispcore>sources>cl-error.\;11
 35371  

      |changes| |to:|  (functions define-condition normalize-slot-descriptions split-proceed-clauses 
                              proceed-case-from-clause process-proceed-keywords check-*case-selector 
                              collect-case-selectors cl:ctypecase cl:ecase)
                       (vars cl-errorcoms)

      |previous| |date:| "24-Oct-86 19:11:27" {eris}<lispcore>sources>cl-error.\;10)


; Copyright (c) 1986 by Xerox Corporation.  All rights reserved.

(prettycomprint cl-errorcoms)

(rpaqq cl-errorcoms
 
       ((coms (* |;;| 
               "Temporary bootstrapping stuff. Anything in here gets changed once CL starts working."
                 )
              (functions condition-typecase condition-block condition-return))
        (coms (* |;;| "Internal stuff.")
              (export (variables %condition-types-real))
              (functions default-proceed-report)
              (functions with-gensyms with-err-loop-vars strip-keywords make-fake-report-function 
                     make-report-function make-encapsulation normalize-slot-descriptions 
                     extract-condition-bindings normalize-condition-clauses 
                     massage-catch-condition-clauses split-proceed-clauses proceed-case-from-clause 
                     process-proceed-keywords check-*case-selector collect-case-selectors 
                     no-proceed-test %prefix-symbol %suffix-symbol proceed-arg-collector))
        (coms (* |;;| 
           "User-visible forms. These should all be external symbols. Any others should be internal."
                 )
              (functions define-condition cl:check-type cl:etypecase cl:ctypecase cl:ecase cl:ccase 
                     cl:assert handler-bind condition-bind condition-case real-condition-case 
                     ignore-errors proceed-case real-proceed-case define-proceed-function catch-abort
                     ))
        (prop filetype cl-error)
        (declare\: donteval@load doeval@compile dontcopy compilervars (addvars (nlama)
                                                                             (nlaml)
                                                                             (lama)))))



(* |;;| "Temporary bootstrapping stuff. Anything in here gets changed once CL starts working.")


(defmacro condition-typecase
 (object &rest clauses)
   (let
    ((val (cl:gensym)))
    (cl:if %condition-types-real `(cl:typecase ,object ,@clauses)
           `(let ((,val ,object))
                 (cond
                    ,@(cl:mapcar (function (cl:lambda
                                            (clause)
                                            (destructuring-bind
                                             (selector . body)
                                             clause
                                             (cl:if (eq selector t)
                                                    clause
                                                    `((condition-typep ,val ',selector)
                                                      ,@body)))))
                             clauses))))))

(defmacro condition-block
 (tag &body forms) `(cl:catch ',tag ,@forms))

(defmacro condition-return
 (tag &optional result) `(cl:throw ',tag ,result))




(* |;;| "Internal stuff.")


(* FOLLOWING DEFINITIONS EXPORTED)


(cl:defconstant %condition-types-real
 nil)



(* END EXPORTED DEFINITIONS)

(defmacro default-proceed-report
 (proceed-type) `(get ,proceed-type '%default-proceed-report
                                                      'default-proceed-reporter))

(defmacro with-gensyms
 (vars prefix &body body)
   `(let ,(mapcar vars (function (cl:lambda (var)
                                        `(,var (gensym ,prefix))))) ,@body))

(defmacro with-err-loop-vars
 (prefix &body body) `(with-gensyms (val block-name again)
                                                         ,prefix
                                                         ,@body))

(cl:defun strip-keywords
 (args) (cl:values (for
 old
 args on
 args by
 cddr
                                              while
 (cl:keywordp (cl:first args))
                                              collect
 (list (cl:first args)
                                                            (cl:second args)))
                                       args))

(cl:defun make-fake-report-function
 (datum bound-var &optional encapsulation)
   (cl:etypecase datum (string `(lambda (datum stream)
                                  (declare
 (ignore datum))
                                  (cl:write-string ,datum stream)))
          (list `(lambda (,bound-var *standard-output*)
                   ,(cl:if (null encapsulation)
                           datum
                           `(let ,encapsulation ,datum))))))

(cl:defun make-report-function
 (datum bound-var &optional type-name)
   (cl:etypecase datum (string `(lambda (datum stream)
                                  (declare
 (ignore datum))
                                  (cl:write-string ,datum stream)))
          (list `(lambda (,bound-var *standard-output*)
                   ,(cl:if type-name `(with
 ,type-name ,bound-var ,datum) datum)))))

(cl:defun make-encapsulation
 (condition-type slot-names)
   (mapcar (cl:remove '--dummy-slot-- slot-names)
          (function (lambda (slot)
                      `(,slot (,(%suffix-symbol condition-type (cl:concatenate 'string "-"
                                                                      (cl:symbol-name slot))) 
                                     condition))))))

(cl:defun normalize-slot-descriptions
 (slots)
   (mapcar slots (function (cl:lambda (slot)
                                  (if
 (listp slot)
                                      then
 (if
 (equal (length slot)
                                                      1)
                                               then
 (append slot '(nil :readonly t))
                                             else
 `(,(car slot) ,(cadr slot) :read-only t
                                                          ,@(cddr slot)))
                                    else
 `(,slot nil :read-only t))))))

(cl:defun extract-condition-bindings
 (clauses)
   (mapcar clauses (function (cl:lambda (clause)
                                    `(cons ',(cl:first clause) ,(cl:second clause))))))

(cl:defun normalize-condition-clauses
 (clauses)
   (mapconc clauses (function (cl:lambda
                               (clause)
                               (let ((conditions (cl:first clause)))
                                    (cl:typecase
                                     conditions
                                     (list (cl:if (eq (cl:first conditions)
                                                      'quote)
                                                  (cl:error 
                                                         "Bad condition spec ~s. Should be unquoted." 
                                                         conditions)
                                                  (mapcar conditions
                                                         (function (cl:lambda
                                                                    (c)
                                                                    (cl:if (cl:symbolp c)
                                                                           (cons c (cdr clause))
                                                                           (cl:error 
                                         "Bad condition spec ~s. Should be list of unquoted symbols." 
                                                                                  conditions)))))))
                                     (cl:symbol (list clause))
                                     (t (cl:error 
                                        "Bad condition spec ~s. Should be symbol or list of symbols." 
                                               conditions))))))))

(cl:defun massage-catch-condition-clauses
 (clauses init-value)
   (mapcar clauses (function (cl:lambda
                              (clause)
                              (destructuring-bind
                               (selector bvl . forms)
                               clause
                               (cl:if (null bvl)
                                      (cons selector forms)
                                      (list selector `(let (,(list (car bvl)
                                                                   init-value) ,@(cdr bvl))
                                                           ,@forms))))))))

(cl:defun split-proceed-clauses
 (clauses tag)
   (let
    (cases bodies)
    (for
 clause in
 clauses as
 selector from
 0
       do
 (destructuring-bind
           (name vars)
           clause
           (cl:multiple-value-bind
            (test report tail)
            (process-proceed-keywords name (cddr clause))
            (if
 (null name)
                then
 (cl:unless test (cl:setf test 'true))
                     (cl:unless report (cl:error 
                                              "Unnamed proceed cases must have a report method: ~S" 
                                              clause))
              else
 (cl:unless test (if
 (not (get name '%default-proceed-test))
                                       then
 (cl:warn 
                                           "No test specified for proceed type ~A: may be undefined." 
                                                   name)))
                   (cl:unless report (cl:setf report `(cl:lambda (pc stream)
                                                             (cl:funcall (default-proceed-report
                                                                          ',name)
                                                                    pc stream)))))
            (cl:push `(make-proceed-case :name ',name :tag ,tag :selector ,selector :test
                             ,(and test `(function ,test)) :report (function ,report)) cases)
            (cl:push `(,selector (function (cl:lambda ,vars ,@tail))) bodies))))
    (cl:values (reverse cases)
           (reverse bodies))))

(cl:defun proceed-case-from-clause
 (clause tag dummy)
   (destructuring-bind
    (name vars . tail)
    clause
    (cl:multiple-value-bind
     (test report body)
     (process-proceed-keywords name tail)
     (if
 (null name)
         then
 (cl:unless test (cl:setf test 'true))
              (cl:unless report (cl:error "Unnamed proceed cases must have a report method: ~S" 
                                       clause))
       else
 (cl:unless test (if
 (not (get name '%default-proceed-test))
                                then
 (cl:warn 
                                           "No test specified for proceed type ~A: may be undefined." 
                                            name)))
            (cl:unless report (cl:setf report `(cl:lambda (pc stream)
                                                      (cl:funcall (default-proceed-report
                                                                   ',name)
                                                             pc stream)))))
     `(make-real-proceed-case :name ',name :tag ,tag :continuation
             (function (cl:lambda (&optional ,@(or vars (list dummy)))
                              ,@body))
             :test
             ,(and test `(function ,test)) :report (function ,report)))))

(cl:defun process-proceed-keywords
 (name arg)
   (let (test report)
        (cl:multiple-value-bind
         (keys tail)
         (strip-keywords arg)
         (|for|
 pair |in|
 keys
            |do|
 (destructuring-bind (key value)
                        pair
                        (case key (:test (cl:if test (cl:error 
                                                 "Duplicate test form specified for proceed type ~S." 
                                                            name))
                                         (cl:setf test value))
                              (:condition (cl:if test (cl:error 
                                                 "Duplicate test form specified for proceed type ~S." 
                                                             name))
                                     (cl:setf test `(cl:lambda (c)
                                                           (condition-typep c ',value))))
                              (:report-function (cl:if report (cl:error 
                                               "Duplicate report form specified for proceed type ~S." 
                                                                     name))
                                     (cl:setf report value))
                              (:report (cl:if report (cl:error 
                                               "Duplicate report form specified for proceed type ~S." 
                                                            name))
                                     (cl:setf report (make-report-function value 'proceed-case)))
                              (cl:otherwise (cl:cerror "Ignore key/value pair" 
                                                   "Illegal keyword ~S in proceed case ~S." key name)
                                     ))))
         (cl:values test report tail))))

(cl:defun check-*case-selector
 (selector name) (cl:if (or (eq selector 't)
                                                          (eq selector 'cl:otherwise))
                                                      (cl:error "~A not allowed in the ~A form." 
                                                             selector name)
                                                      selector))

(cl:defun collect-case-selectors
 (clauses name)
   (mapconc clauses (function (cl:lambda (clause)
                                     (if
 (and (cl:consp (car clause))
                                              (fmemb name '(cl:ecase cl:ccase)))
                                         then
 (cl:copy-list (car clause))
                                       else
 (list (check-*case-selector (car clause)
                                                         name)))))))

(cl:defun no-proceed-test
 (name &aux once)
   (proceed-case (handler-bind ((no-proceed-test (function (cl:lambda
                                                            (c)
                                                            (cl:when (eq (no-proceed-test-name c)
                                                                         name)
                                                                   (cl:if once (cl:throw '
                                                                                    skip-proceed-case 
                                                                                      nil)
                                                                          (cl:setf once t)))))))
                        (cl:error 'no-proceed-test :name name))
          (nil nil :report "Use FALSE for the test" :condition no-proceed-test (function false))
          (proceed nil :report "Make TRUE the default test" :condition no-proceed-test
                 (cl:setf (default-proceed-test name)
                        (function true)))))

(cl:defun %prefix-symbol
 (prefix cl:symbol) (cl:intern (cl:concatenate 'string prefix (cl:symbol-name
                                                                                       cl:symbol))
                                                   (cl:symbol-package cl:symbol)))

(cl:defun %suffix-symbol
 (cl:symbol suffix) (cl:intern (cl:concatenate 'string (cl:symbol-name 
                                                                                      cl:symbol)
                                                              suffix)
                                                   (cl:symbol-package cl:symbol)))

(defmacro proceed-arg-collector
 (name) "Function that collects user-specified optional args (excluding the condition) for a named proceed case."
   `(get ,name '%proceed-arg-collector))




(* |;;| "User-visible forms. These should all be external symbols. Any others should be internal.")


(defdefiner define-condition

   structures
   (name parent-type &rest args)
   "Defines a new condition type"
   (cl:flet
    ((extract-slot-name (slot)
            (if
 (cl:consp slot)
                then
 (car slot)
              else
 slot)))
    (let
     ((class-options `(,@(cl:if %condition-types-real '((:print-function %print-condition))
                                '((:type list)
                                  :named)) (:constructor ,(%prefix-symbol "%MAKE-" name))
                             (:copier nil)
                             (:predicate nil)))
      reporter handler encapsulation)
     (cl:multiple-value-bind
      (keys slot-descriptions)
      (strip-keywords args)
      (cl:setf slot-descriptions (normalize-slot-descriptions slot-descriptions))
      (and (neq parent-type name)
           (let* ((all-super-slots (slot-list parent-type))
                  (redefined-slots (for
 slot in
 slot-descriptions when
 (cl:member (car slot)
                                                                              all-super-slots)
                                      collect
 slot)))
                 (cl:push (list* :include parent-type redefined-slots)
                        class-options)
                 (cl:setf slot-descriptions (for
 slot in
 slot-descriptions
                                               unless
 (cl:member slot redefined-slots) collect
 slot))
                 ))
      (cl:unless (and nil %condition-types-real)
             (cl:setf encapsulation (make-encapsulation name (append (mapcar (slot-list parent-type)
                                                                            (function 
                                                                             extract-slot-name))
                                                                    (mapcar slot-descriptions
                                                                           (function 
                                                                            extract-slot-name))))))
      (for
 pair in
 keys
         do

         (destructuring-bind
          (key value)
          pair
          (case key (:conc-name (cl:push pair class-options))
                (:report-function (if
 reporter
                                      then
 (cl:error "Report function already specified for ~S." name
                                                  )
                                    else
 (cl:setf reporter value)))
                (:report (if
 reporter
                             then
 (cl:error "Report function already specified for ~S." name)
                           else
 (cl:setf reporter (cl:if (and nil %condition-types-real)
                                                         (make-report-function value 'condition name)
                                                         (make-fake-report-function value
                                                                'condition encapsulation)))))
                (:handler-function (if
 handler
                                       then
 (cl:error "Handler already specified for ~S." name)
                                     else
 (cl:setf handler value)))
                (:handle (if
 handler
                             then
 (cl:error "Handler already specified for ~S." name)
                           else
 (cl:setf handler `(lambda (condition)
                                                    ,(cl:if (null encapsulation)
                                                            value
                                                            `(let ,encapsulation ,value))))))
                (cl:otherwise (cl:cerror "Skip key-value pair" "Illegal keyword ~S in ~S." key
                                     'define-condition)))))
      `(progn (cl:defstruct ((\\\, name)
 ,@class-options) ,@slot-descriptions )

              ,@(cl:if (neq name parent-type)
                       `((fix-inheritance-links ',name ',parent-type)))
              ,@(cl:if (cl:consp handler)
                       (let ((handler-name (%suffix-symbol name " default handler")))
                            (prog1 `((cl:setf (cl:symbol-function ',handler-name)
                                            (function ,handler))) (setq handler handler-name))))
              (cl:setf (condition-handler ',name)
                     ,(and handler `(function ,handler)))
              ,@(cl:if (cl:consp reporter)
                       (let ((reporter-name (%suffix-symbol name " report method")))
                            (prog1 `((cl:setf (cl:symbol-function ',reporter-name)
                                            (function ,reporter))) (setq reporter reporter-name))))
              (cl:setf (condition-reporter ',name)
                     ,(and reporter `(function ,reporter)))
              ',name)))))

(defmacro cl:check-type
 (place typespec &optional string)
   (with-err-loop-vars "CHECK-TYPE" `(cl:block ,block-name
                                            (cl:tagbody ,again
                                                   (let ((,val ,place))
                                                        (cl:when (typep ,val ',typespec)
                                                               (cl:return-from ,block-name))
                                                        (cl:setf ,place (check-type-fail
                                                                         t
                                                                         ',place
                                                                         ,val
                                                                         ',typespec
                                                                         ,string))
                                                        (go ,again))))))

(defmacro cl:etypecase
 (keyform &body clauses)
   (with-gensyms (value)
          "ETYPECASE"
          (let ((case-selectors (cons 'or (collect-case-selectors clauses 'cl:etypecase))))
               `(let ((,value ,keyform))
                     (cl:typecase ,value ,@clauses (t (check-type-fail nil ',keyform ,value
                                                             ',case-selectors nil)))))))

(defmacro cl:ctypecase
 (keyplace &body clauses)
   (let ((case-selectors (cons 'or (collect-case-selectors clauses 'cl:ctypecase))))
        (with-err-loop-vars
         "CTYPECASE"
         `(cl:block ,block-name (cl:tagbody
                                 ,again
                                 (let ((,val ,keyplace))
                                      (cl:return-from ,block-name
                                             (cl:typecase ,val ,@clauses
                                                    (t (cl:setf ,keyplace (check-type-fail
                                                                           t
                                                                           ',keyplace
                                                                           ,val
                                                                           ',case-selectors nil))
                                                       (go ,again))))))))))

(defmacro cl:ecase
 (keyform &rest clauses)
   (with-gensyms (value)
          "ECASE"
          (let ((case-selectors (collect-case-selectors clauses 'cl:ecase)))
               (cl:if case-selectors `(let ((,value ,keyform))
                                           (case ,value ,@clauses (t (ecase-fail nil
                                                                            ',keyform
                                                                            ,value
                                                                            ',case-selectors))))
                      (cl:error "Empty case statement.")))))

(defmacro cl:ccase
 (keyform &body clauses)
   (let ((case-selectors (collect-case-selectors clauses 'cl:ccase)))
        (cl:unless case-selectors (cl:error "Empty CCASE."))
        (with-err-loop-vars
         "CCASE"
         `(cl:block ,block-name (cl:tagbody
                                 ,again
                                 (let ((,val ,keyform))
                                      (cl:return-from ,block-name
                                             (case ,val ,@clauses
                                                   (t (cl:setf ,keyform (ecase-fail
                                                                         t
                                                                         ',keyform
                                                                         ,val
                                                                         ',case-selectors))
                                                      (go ,again))))))))))

(defmacro cl:assert
 (test-form &optional places string &rest args)
   (cl:unless (cl:listp places)
          (cl:error "~S should be a list of places." places))
   (with-err-loop-vars "ASSERT" `(cl:block ,block-name (cl:tagbody ,again (cl:when
                                                                           ,test-form
                                                                           (cl:return-from
                                                                            ,block-name
                                                                            (cl:values)))
                                                              (assert-fail ,string ,@args)
                                                              (go ,again)))))

(defmacro handler-bind
 (bindings &rest forms) "Eval forms under temporary new condition handlers."
   `(let ((*condition-handler-bindings* (list* ,@(extract-condition-bindings (
                                                                          normalize-condition-clauses
                                                                              bindings)) 
                                               *condition-handler-bindings*)))
         ,@forms))

(defmacro condition-bind
 (bindings &rest forms) 
                        "Eval forms under temporary new condition handlers; synonym for HANDLER-BIND"
   `(handler-bind ,bindings ,@forms))

(defmacro condition-case
 (form &rest bindings) 
                           "Eval form under condition handlers that provide alternate continuations."
   (with-gensyms
    (condition cl:values bname handler)
    "CONDITION-CASE"
    (let
     ((clauses (normalize-condition-clauses bindings)))
     (|if|
 (null clauses)
         |then|
 form
       |else|
 `(let* ((,condition nil)
                      (,cl:values (condition-block
                                   ,bname
                                   (let ((,handler (function (cl:lambda (c)
                                                                    (cl:setf ,condition c)
                                                                    (condition-return ,bname)))))
                                        (handler-bind ((,(cl:mapcar (function car)
                                                                clauses) ,handler))
                                               (cl:multiple-value-list ,form))))))
                     (cl:if ,condition ,(|if|
 (eql (length clauses)
                                                   1)
                                            |then|
 (cadr (car (massage-catch-condition-clauses 
                                                                     clauses condition)))
                                          |else|
 `(condition-typecase ,condition
                                                         ,@(massage-catch-condition-clauses clauses 
                                                                  condition)
                                                         (t (cl:error 
                                                  "Bug in condition-case!~&Unexpected condition: ~S."
                                                                   ,condition)))) (cl:values-list
                                                                                   ,cl:values)))))))

(defmacro real-condition-case
 (form &rest cases) 
                           "Eval form under condition handlers that provide alternate continuations."
   (with-gensyms
    (outer inner condition dummy)
    "CONDITION-CASE"
    `(cl:block
      ,outer
      (cl:multiple-value-call
       'cl:funcall
       (cl:block
        ,inner
        (handler-bind
         ,(for
 case in
 cases
             collect

             (destructuring-bind
              (types bvl . body)
              case
              `(,types
                (function (cl:lambda
                           (,condition)
                           (cl:return-from
                            ,inner
                            (cl:values
                             (function (cl:lambda
                                        ,@(cl:if bvl (list bvl)
                                                 `((,dummy)
                                                   (declare
 (ignore ,dummy))))
                                        ,@body))
                             ,condition)))))))
         (cl:return-from ,outer ,form)))))))

(defmacro ignore-errors
 (&body forms) "Eval forms with handler for any condition of type ERROR."
   `(condition-case (progn ,@forms)
           (error (condition)
                  nil)))

(defmacro proceed-case
 (form &rest clauses) 
                                           "Eval forms, establishing a place to proceed from errors."
   (with-gensyms
    (selector cl:values tag)
    "PROCEED-CASE"
    (cl:multiple-value-bind
     (cases bodies)
     (split-proceed-clauses clauses tag)
     (|if|
 (null cases)
         |then|
 form
       |else|
 `(destructuring-bind (,selector \\\, cl:values)
                      (let ((,tag (list nil)))
                           (cl:catch ,tag (cons :normal (let ((*proceed-cases* (list* ,@cases 
                                                                                      *proceed-cases*
                                                                                      )))
                                                             (cl:multiple-value-list ,form)))))
                      (cl:if (eq ,selector :normal)
                             (cl:values-list ,cl:values)
                             (cl:apply ,(|if|
 (eql (length bodies)
                                                   1)
                                            |then|
 (cadr (car bodies))
                                          |else|
 `(case ,selector ,@bodies)) ,cl:values)))))))

(defmacro real-proceed-case
 (form &rest clauses) 
                                           "Eval forms, establishing a place to proceed from errors."
   (with-gensyms (outer tag dummy)
          "PROCEED-CASE"
          `(cl:block ,outer (let* ((,tag (list nil))
                                   (*proceed-cases* (list* ,@(mapcar clauses
                                                                    (function (cl:lambda (clause)
                                                                                     (
                                                                             proceed-case-from-clause
                                                                                      clause tag 
                                                                                      dummy)))) 
                                                           *proceed-cases*)))
                                  (cl:multiple-value-call 'cl:funcall (cl:catch ,tag
                                                                             (cl:return-from
                                                                              ,outer
                                                                              ,form)))))))

(defdefiner define-proceed-function

   functions
   (name &rest tail &aux vars)
   (cl:multiple-value-bind
    (test report arglist)
    (process-proceed-keywords name tail)
    (cl:setf vars (mapcar arglist (function (lambda (x)
                                              (cl:if (cl:symbolp x)
                                                     x
                                                     (car x))))))
    (cl:unless test (cl:setf test 'true))
    (cl:unless report (cl:setf report 'default-proceed-reporter))
    `(progn ,@(cl:if (cl:consp test)
                     (let ((tester (%suffix-symbol name "-proceed-test")))
                          (prog1 `((cl:setf (cl:symbol-function ',tester)
                                          (function ,test))) (setq test tester))))
            (cl:setf (default-proceed-test ',name)
                   ',test)
            ,@(cl:if (cl:consp report)
                     (let ((reporter (%suffix-symbol name "-proceed-reporter")))
                          (prog1 `((cl:setf (cl:symbol-function ',reporter)
                                          (function ,report))) (setq report reporter))))
            (cl:setf (default-proceed-report ',name)
                   ',report)
            (cl:setf (proceed-arg-collector ',name)
                   (function (cl:lambda (&optional condition ,@arglist)
                                    (list ,@vars))))
            (cl:defun (\\\,
 name) (&optional condition ,@arglist) (condition-case
                                                                   (invoke-proceed-case
                                                                    ',name condition ,@vars)
                                                                   (bad-proceed-case nil nil)))
)))

(defmacro catch-abort
 (print-form &body forms) `(proceed-case (progn ,@forms)
                                                       (abort (condition)
                                                              :report
                                                              ,print-form :test true (cl:values
                                                                                      nil condition))
                                                       ))


(putprops cl-error filetype
 cl:compile-file)
(declare\: donteval@load doeval@compile dontcopy compilervars 

(addtovar nlama
 )

(addtovar nlaml
 )

(addtovar lama
 )
)
(putprops cl-error copyright ("Xerox Corporation" 1986))
(declare\: dontcopy
  (filemap (nil)))
stop