Diff for /gforth/environ.fs between versions 1.1 and 1.13

version 1.1, 1994/02/11 16:30:46 version 1.13, 1997/07/06 14:11:20
Line 1 Line 1
 \ ENVIRON.FS   Answer environmental queries            20may93jaw  \ environmental queries
   
 \ May be cross-compiled  \ Copyright (C) 1995 Free Software Foundation, Inc.
   
 decimal  \ This file is part of Gforth.
   
 AVARIABLE EnvLink 0 EnvLink !  \ Gforth is free software; you can redistribute it and/or
   \ modify it under the terms of the GNU General Public License
   \ as published by the Free Software Foundation; either version 2
   \ of the License, or (at your option) any later version.
   
 : (env)  \ This program is distributed in the hope that it will be useful,
        EnvLink linked  \ but WITHOUT ANY WARRANTY; without even the implied warranty of
        dup c, here over chars allot swap move align  \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
        , ;  \ GNU General Public License for more details.
   
 : (2env)  \ You should have received a copy of the GNU General Public License
        EnvLink linked  \ along with this program; if not, write to the Free Software
        dup $80 or  \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
        c, here over chars allot swap move align  
        , , ;   \ wordlist constant environment-wordlist
   
 : env" ( n -- )  Create environment-wordlist  wordlist drop
        State @  
        IF   postpone S" postpone (env)  : environment? ( c-addr u -- false / ... true ) \ core environment-query
        ELSE [char] " parse (env) THEN ; immediate      environment-wordlist search-wordlist if
           execute true
 : 2env" ( d -- )      else
        State @          false
        IF   postpone S" postpone (2env)      endif ;
        ELSE [char] " parse (2env) THEN ; immediate  
   : e? name environment? ; immediate
   
 : environment?  EnvLink  environment-wordlist set-current
                 BEGIN   @ dup  get-order environment-wordlist swap 1+ set-order
                 WHILE   dup cell+ count $1f and  
                         4 pick 4 pick compare 0=  \ assumes that chars, cells and doubles use an integral number of aus
                         IF      nip nip cell+ count dup -rot  
                                 $1f and + aligned  \ this should be computed in C as CHAR_BITS/sizeof(char),
                                 swap $80 and IF 2@ ELSE @ THEN  \ but I don't know any machine with gcc where an au does not have 8 bits.
                                 EXIT  8 constant ADDRESS-UNIT-BITS ( -- n ) \ environment
                         THEN  1 ADDRESS-UNIT-BITS chars lshift 1- constant MAX-CHAR
                 REPEAT  MAX-CHAR constant /COUNTED-STRING
                 drop 2drop false ;  ADDRESS-UNIT-BITS cells 2* 2 + constant /HOLD
   &84 constant /PAD
   true constant CORE
   true constant CORE-EXT
   1 -3 mod 0< constant FLOORED
   
   1 ADDRESS-UNIT-BITS cells 1- lshift 1- constant MAX-N
   -1 constant MAX-U
   
   -1 MAX-N 2constant MAX-D
   -1. 2constant MAX-UD
   
   version-string 2constant gforth \ version string (for versions>0.3.0)
   \ the version strings of the various versions are guaranteed to be
   \ sorted lexicographically
   
   : return-stack-cells ( -- n )
       [ forthstart 6 cells + ] literal @ cell / ;
   
   : stack-cells ( -- n )
       [ forthstart 4 cells + ] literal @ cell / ;
   
   : floating-stack ( -- n )
       [ forthstart 5 cells + ] literal @
       [IFDEF] float  float  [ELSE]  [ 1 floats ] Literal [THEN] / ;
   
   \ !! max-float
   15 constant #locals \ 1000 64 /
       \ One local can take up to 64 bytes, the size of locals-buffer is 1000
   maxvp constant wordlists
   
   forth definitions
   previous
   

Removed from v.1.1  
changed lines
  Added in v.1.13


FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>