;;; -------------------------------------------------------------------------------- ;;; Hilfsfunktionen für die Funktion CL:DEFCONSTANT ;;; -------------------------------------------------------------------------------- (vl-load-com) (defun cl:format (stream dest vals / txts dimzin) (if (and (vl-symbolp stream) (eq '-? stream)) (progn (princ (strcat "Aufruf: (cl:format stream \"Destination-String\" '(values ...)\n" " stream t => Ausgabe auf Konsole\n" " stream nil => Rückgabe als String\n" " stream # => Ausgabe in Datei\n\n" " Destination-String: \n" " jedes ~A wird durch die Ausgabe mit (vl-princ-to-string value) ersetzt\n" " jedes ~S wird durch die Ausgabe mit (vl-prin1-to-string value) ersetzt\n" " jedes ~D wird durch (itoa IntegerValue) ersetzt\n" " jedes ~, wird durch (rtos numberValue 2 ) ersetzt\n" " jedes ~@ wird durch die Elemente der ValueList ersetzt\n" " (cl:format nil \"das sind meine kinder ~@\" '((Heike Gabi Manni)))\n" " => \"das sind meine kinder HEIKE GABI MANNI\"\n" "Beispiel: (cl:format nil \n" " \"~A hat eine Seitenlänge von ~,3m und eine Höhe von ~Dm\\nDas ergibt einen umbauten Raum von ~,3m³\"\n" " (list \"Der Quader\" 2.5 4 (* 2.5 2.5 4)))\n" "Ausgabe: \n\"Der Quader hat eine Seitenlänge von 2.500m und eine Höhe von 4m\nDas ergibt einen umbauten Raum von 25m³\"")) (prin1)) (progn (setq dimzin (getvar "dimzin")) (setvar "dimzin" 0) (setq txts ((lambda (vals defs txt / pos n cnt) (setq cnt 0 pos 0) (while (setq pos (vl-string-position 126 txt pos)) (setq n (strcase (substr txt (+ 2 pos) 1))) (cond ((= n "A") (setq txt (vl-string-subst (VL-PRINC-TO-STRING (nth cnt vals)) "~A" txt pos) cnt (1+ cnt))) ((= n "D") (setq txt (vl-string-subst (itoa (nth cnt vals)) "~D" txt pos) cnt (1+ cnt))) ((= n "S") (setq txt (vl-string-subst (VL-PRIN1-TO-STRING (nth cnt vals)) "~S" txt pos) cnt (1+ cnt))) ((= n ",") (setq txt (vl-string-subst (rtos (nth cnt vals) 2 (setq n (atoi (substr txt (+ 3 pos))))) (strcat "~," (itoa n)) txt pos) cnt (1+ cnt))) ((= n "@") (setq txt (vl-string-subst (apply 'strcat (mapcar (function (lambda (val) (strcat (VL-PRIN1-TO-STRING val) " "))) (nth cnt vals))) "~@" txt pos) cnt (1+ cnt))))) txt) (cond ((atom vals) (list vals)) ((vl-consp vals) vals) (t (list vals))) (mapcar 'type vals) dest)) (setvar "dimzin" dimzin) (if stream (if (= (type stream) 'file) (princ txts stream) (princ txts)) txts)))) ;;; (cl:Stringp variable) Beispiel: value = "TEXT" (cl:stringp value) => T (defun CL:STRINGP (string) (eq (type string) 'str)) ;;; (cl:Error "Fehlermeldung Formatierung siehe (cl:Format '-? nil nil)" [Wert | nil | '(wert1 wert2 ...)) (defun cl:error (msg args / msgn) (cond ((and (vl-symbolp msg) (eq '-? msg)) (princ (VL-PRIN1-TO-STRING '(cl:Error "Fehlermeldung Formatierung siehe (cl:Format '-? nil nil)" [Wert | nil | '(wert1 wert2 ...)))) (prin1)) (CL:STRINGP msg) (setq msgn(cl:format nil (strcat "\nEs ist ein Fehler in Ihrer Anwendung aufgetreten\nBeschreibung:\n" msg) (if (or (vl-consp args) (null args)) args (list args)))) (cl:format t msgn nil) (VL-EXIT-WITH-ERROR msgn)) ((numberp msg) (VL-EXIT-WITH-VALUE msg)))) ;;; (cl:inplst2lst '(1 . 2)) => '(1 2) wandelt AssocListen in normale Listen um (defun cl:inplst2lst(Lst) (cond ((null lst) nil) ((atom lst) lst) ((vl-consp lst) (if (vl-consp (cdr lst)) (cons (cl:inplst2lst (car lst)) (cl:inplst2lst (cdr lst))) (list (cl:inplst2lst (car lst)) (cdr lst)))))) ;;; (cl:gensym-nil) erzeugt ein eineindeutiges Symbol #:G (defun cl:gensym-nil (/ sym) (if *gensym-counter* (progn (while (boundp (setq sym (read (strcat "#:G" (itoa (setq *gensym-counter* (1+ *gensym-counter*)))))))) sym) (progn (setq *gensym-counter* 0) '#:G0))) ;;; (CL:DEFCONSTANT 'MeineSymbolListe '(Das ist meine Symbolliste)) ;;; (CL:DEFCONSTANT 'MeinSymbol 5) (DEFUN CL:DEFCONSTANT (SYMBOL VALUE / PARAM PRSCR SCRNAM ll gsym) (if (and (eq '-? symbol) (not value)) (progn (princ "\nKonstante in AutoLisp definieren (CL:DEFCONSTANT 'name value) Beispiel: (CL:DEFCONSTANT 'MeineSymbolListe '(Das ist meine Symbolliste)) => (DAS IST MEINE SYMBOLLISTE) (CL:DEFCONSTANT 'MeineSymbolListe 5) => Das Symbol MeineSymbolListe ist ein geschütztes Symbol (type LIST) und kann nicht benutzt werden") (prin1)) (COND ((VL-SYMBOLP SYMBOL) (COND ((and (NOT (MEMBER SYMBOL (if (vl-list-length *CL-PROTECTED-SYMBOLS*) (setq ll *CL-PROTECTED-SYMBOLS*) (setq ll (cl:inplst2lst *CL-PROTECTED-SYMBOLS*))))) (if symbol (not (member (type (VL-SYMBOL-VALUE symbol)) '(SUBR EXRXSUBR EXSUBR))) t)) (IF (VL-CATCH-ALL-ERROR-P (VL-CATCH-ALL-APPLY 'SET (LIST SYMBOL VALUE))) (cl:error "\nDas Symbol ~A ist ein geschütztes Symbol (type ~A) und kann nicht benutzt werden" (list symbol (type (VL-SYMBOL-VALUE symbol)))) (IF *CL-PROTECTED-SYMBOLS* (PROGN (SETQ PRSCR (OPEN (SETQ SCRNAM (STRCAT (GETENV "temp") "\\pragmascript.lsp")) "w")) (cl:format PRSCR "(setq ~A '~A)\n" (list (setq gsym (cl:gensym-nil)) ll)) (cl:format PRSCR "(pragma '((unprotect-assign *cl-protected-symbols*)))\n" nil) (cl:format PRSCR "(SETQ *CL-PROTECTED-SYMBOLS* (cons '~A '~S))\n" (list symbol ll)) (cl:format PRSCR "(pragma '((protect-assign ~A *CL-PROTECTED-SYMBOLS*)))\n(setq ~A nil)" (list symbol gsym)) (SETQ PRSCR (CLOSE PRSCR)) (LOAD SCRNAM) (vl-file-delete scrnam) VALUE) (PROGN (SETQ PRSCR (OPEN (SETQ SCRNAM (STRCAT (GETENV "temp") "\\pragmascript.lsp")) "w")) (cl:format PRSCR "(pragma '((unprotect-assign *cl-protected-symbols*)))\n" nil) (cl:format PRSCR "(SETQ *CL-PROTECTED-SYMBOLS* '(~A))\n" (list symbol )) (cl:format PRSCR "(pragma '((protect-assign ~A *CL-PROTECTED-SYMBOLS*)))\n" (list symbol)) (SETQ PRSCR (CLOSE PRSCR)) (LOAD SCRNAM) (vl-file-delete SCRNAM) VALUE)))) (T (cl:ERROR "Das Symbol ~A ist ein geschütztes Symbol (type ~A) und kann nicht benutzt werden" (list symbol (type (vl-symbol-value symbol))))))) (T (cl:ERROR "\nDie Konstante muss ein Symbol sein\nEingabe (cl:defconstant 'Name value)\n" nil))))) ;;; Funktion CL:Erase-Protected-Symbol entfernt den Schutz des Symbols und setzt den Wert des symbols auf nil (defun CL:Erase-Protected-Symbol (Symbol / PRSCR SCRNAM tmp) (if (and (VL-SYMBOLP SYMBOL) (MEMBER SYMBOL (if (vl-list-length *CL-PROTECTED-SYMBOLS*) (setq tmp *CL-PROTECTED-SYMBOLS*) (setq tmp(cl:inplst2lst *CL-PROTECTED-SYMBOLS*))))) (progn (SETQ PRSCR (OPEN (SETQ SCRNAM (STRCAT (GETENV "temp") "\\pragmascript.lsp")) "w")) (cl:format PRSCR "(pragma '((unprotect-assign ~A *cl-protected-symbols*)))\n" (list symbol )) (cl:format PRSCR "(SETQ *CL-PROTECTED-SYMBOLS* (vl-remove '~A *CL-PROTECTED-SYMBOLS*))\n" (list symbol)) (cl:format PRSCR "(pragma '((protect-assign ~A ~@)))\n" (list '*CL-PROTECTED-SYMBOLS* (vl-remove symbol tmp))) (cl:format PRSCR "(setq ~A nil)" (list symbol)) (setq PRSCR (close PRSCR)) (load SCRNAM) (vl-file-delete SCRNAM)))) ;|«Visual LISP© Format Options» (120 2 4 0 nil "Ende von " 90 6 0 0 1 nil T nil T) ;*** KEINEN Text unterhalb des Kommentars hinzufügen! ***|;